home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 4a.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  69.0 KB  |  2,416 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "4.h"
  10. #include "attr.h"
  11. #include "setprots.h"
  12. #include "evalprots.h"
  13. #include "errmsgprots.h"
  14. #include "dclmapprots.h"
  15. #include "sspansprots.h"
  16. #include "nodesprots.h"
  17. #include "miscprots.h"
  18. #include "smiscprots.h"
  19. #include "utilprots.h"
  20. #include "chapprots.h"
  21.  
  22. static int constraint_kind(Symbol);
  23. static void make_constrained_node(Node, Symbol, int);
  24. static void dereference_node(Node, Symbol);
  25. static Symbol resolve2_attr(Node, Symbol);
  26. static int in_univ_attributes(int);
  27. static void check_bounds_in_range(Node, Node, Symbol);
  28. static void check_array_conversion(Node, Symbol, Symbol);
  29. static int reads_prefix(int, Symbol);
  30.  
  31. int in_type_classes(Symbol sym)                             /*;in_type_classes*/
  32. {
  33.     /* return true if sym in type_classes, as defined in check_type*/
  34.     /* New procedure aqdded for c version */
  35.     return (
  36.          sym == symbol_boolean_type 
  37.       || sym == symbol_discrete_type   
  38.       || sym == symbol_integer_type
  39.       || sym == symbol_real_type
  40.       || sym == symbol_universal_type);
  41. }
  42.  
  43. void check_type_i(Node expn)                                 /*;check_type_i*/
  44. {
  45.     /* check_type('integer_type', expn) */
  46.     check_type(symbol_integer_type, expn);
  47. }
  48.  
  49. void check_type_r(Node expn)                                 /*;check_type_r*/
  50. {
  51.     /* check_type('real_type', expn) */
  52.     check_type(symbol_real_type, expn);
  53. }
  54.  
  55. void check_type_d(Node expn)                                 /*;check_type_d*/
  56. {
  57.     /* check_type('discrete_type', expn) */
  58.     check_type(symbol_discrete_type, expn);
  59. }
  60.  
  61. void check_type_u(Node expn)                                /*;check_type_u*/
  62. {
  63.     /* check_type('universal_type', expn) */
  64.     check_type(symbol_universal_type, expn);
  65. }
  66.  
  67. void check_type(Symbol context_type, Node expn)                /*;check_type*/
  68. {
  69.     /* This procedure performs type checking and operator disambiguation.
  70.      * -expn- is an expression tree, which must have the type -context_type-.
  71.      * This procedure is called in all contexts where the type of
  72.      * an expression is known a priori : assignments, conditionals, etc.
  73.      * The procedure returns the annotated tree for -expn-, labelling each
  74.      * node with its unique type, and resolving overloaded constructs where
  75.      * needed.
  76.      * Some contexts require that a type belong to a class of types instead
  77.      * of one  specific type. For example, a condition must be of a boolean
  78.      * type, not just BOOLEAN.
  79.      */
  80.  
  81.     Set types, otypes;
  82.     Symbol t, old_context;
  83.     Forset    fs1;
  84.  
  85.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_type");
  86.  
  87.     N_TYPE(expn) = symbol_any;        /*By default.*/
  88.     noop_error = FALSE;
  89.  
  90.     resolve1(expn);        /* Bottom-up pass.*/
  91.  
  92.     if (noop_error) {
  93.         noop_error = FALSE;    /* error emitted already*/
  94.         N_TYPE(expn) = symbol_any;
  95.         return;
  96.     }
  97.  
  98.     types = N_PTYPES(expn);
  99.     old_context = context_type;
  100.     if (in_type_classes(context_type)) {
  101.         /* Keep only those that belong to this class.*/
  102.         otypes = set_copy(types);
  103.         types = set_new(0);
  104.         FORSET(t = (Symbol), otypes, fs1);
  105.             if (compatible_types(t, context_type))
  106.                 types = set_with(types, (char *) t);
  107.         ENDFORSET(fs1);
  108.         set_free(otypes);
  109.  
  110.         if (set_size(types) > 1) {
  111.             /* May be overloaded operator: user_defined one hides predefined.*/
  112.             /* types -:= univ_types */
  113.             otypes = set_copy(types); 
  114.             types = set_new(0);
  115.             FORSET(t = (Symbol), otypes, fs1);
  116.                 if (t != symbol_universal_integer && t!= symbol_universal_real)
  117.                     types = set_with(types, (char *)t);
  118.             ENDFORSET(fs1);
  119.             set_free(otypes);
  120.         }
  121.  
  122.         if (set_size(types) == 1) {
  123.             context_type = (Symbol) set_arb (types);
  124.             set_free(types);
  125.         }
  126.         else {
  127.             type_error(set_new1((char *) symbol_any), context_type, 
  128.               set_size(types), expn);
  129.             N_TYPE(expn) = symbol_any;
  130.             set_free(types);
  131.             return;
  132.         }
  133.     }
  134.  
  135.     resolve2(expn, context_type);
  136.  
  137.     if (noop_error) {
  138.         noop_error = FALSE;    /* error emitted already*/
  139.         return;
  140.     }
  141.  
  142.     /* Now emit a constraint qualification if needed.*/
  143.     if (! in_type_classes(old_context)) apply_constraint(expn, context_type);
  144.     if (! in_univ_types(context_type)) eval_static(expn);
  145. }
  146.  
  147. static int constraint_kind(Symbol typ)                     /*;constraint_kind*/
  148. {
  149.     Symbol    d;
  150.  
  151.     if (cdebug2 > 3) {
  152.         TO_ERRFILE("AT PROC :  constraint_kind");
  153.     }
  154.     /* Note that the use of '' in SETL version is translated to zero in
  155.      * the c version. This use of '' is common only to this routine and
  156.      * the next following one.
  157.      */
  158.     if (is_unconstrained(typ) || in_univ_types(typ))  return as_opt;
  159.     if (is_scalar_type(typ)) {
  160.         if (NATURE(typ) == na_enum) return as_opt;
  161.         else return as_qual_range;
  162.     }
  163.     if (is_array(typ))  {
  164.         if (full_others || NATURE(scope_name) == na_record)
  165.             return as_qual_index;
  166.         else return as_opt;
  167.     }
  168.     if (is_record(typ)) {
  169.         if (has_discriminants(typ)) return  as_qual_discr;
  170.         else return as_opt;
  171.     }
  172.     if (is_access(typ)) {
  173.         d = (Symbol) designated_type(typ);
  174.         if (is_scalar_type(d)) return as_opt;
  175.         else if (is_unconstrained(d)) return as_opt;
  176.         else if (is_array(d)) {
  177.             return as_qual_aindex;
  178.         }
  179.         else if (is_record(d)) {
  180.             if (has_discriminants(d)) return as_qual_adiscr;
  181.             else return as_opt;
  182.         }
  183.     }
  184.     return as_opt;
  185. }
  186.  
  187. void apply_constraint(Node expn, Symbol typ)          /*;apply_constraint*/
  188. {
  189.     int    k, constraint;
  190.  
  191.     if (cdebug2 > 3) {
  192.         TO_ERRFILE("AT PROC :  apply constraint");
  193.     }
  194.  
  195.     constraint = constraint_kind(typ);
  196.     /* test of constraint != 0 corresponds to encoding assigned in previous
  197.      * procedure
  198.      */
  199.     k = N_KIND(expn);
  200.  
  201.     /* If node is insert node, lone descendant is original expression.*/
  202.     if (k == as_insert)  apply_constraint(N_AST1(expn), typ);
  203.  
  204.     if (k == as_subtype || k == as_parenthesis || constraint == as_opt)
  205.         return;
  206.     /* the two cases have to be distinguished : a'first..a'last and a'b 
  207.      * in an aggregate, where a qual_range doesn't make any sens.
  208.      */
  209.     if (k == as_attribute
  210.       && ((int) attribute_kind(expn) == ATTR_T_RANGE
  211.       ||  (int) attribute_kind(expn) == ATTR_O_RANGE)
  212.       && constraint == as_qual_range)
  213.         return;
  214.  
  215.     if (k == as_ivalue || (N_TYPE(expn) != typ)
  216.       || (k == as_array_aggregate)
  217.       || (k == as_new && N_AST2(expn) == OPT_NODE)) {
  218.  
  219.         /* The two following lines were in the Setl version : We don't have
  220.          * to keep them since qual_a* is tranformed in qual_* in the code
  221.          * generator
  222.          * if (is_access (typ)) {type_const = (Symbol) designated_type (typ); }
  223.          *    else { type_const = typ; }
  224.          */
  225.         make_constrained_node(expn, typ, constraint);
  226.     }
  227. }
  228.  
  229. static void make_constrained_node(Node expn, Symbol typ, int constraint)
  230.                                                     /*;make_constrained_node*/
  231. {
  232.     Node e_node;
  233.  
  234.     e_node = copy_node(expn);
  235.     N_KIND(expn) = constraint;
  236.     N_AST1(expn) = e_node;
  237.     if (N_AST2_DEFINED(constraint)) N_AST2(expn) = (Node)0;
  238.     if (N_AST3_DEFINED(constraint)) N_AST3(expn) = (Node)0;
  239.     if (N_AST4_DEFINED(constraint)) N_AST4(expn) = (Node)0;
  240.     N_TYPE(expn) = typ;
  241. }
  242.  
  243. int in_priv_types(Symbol s)                                    /*;in_priv_types*/
  244. {
  245.     return (s == symbol_private || s == symbol_limited_private);
  246. }
  247.  
  248. void resolve1(Node expn)                                        /*;resolve1*/
  249. {
  250.     /* This procedure performs the first, bottom-up pass of the type checking
  251.      * and    overload resolution. It     annotates the    expression tree     with the
  252.      * attribute N_PTYPES(expn),  corresponding to the possible  types of the
  253.      * expression.
  254.      */
  255.  
  256.     Fortup ft1;
  257.     Forset fs1, fs2;
  258.     unsigned int    op_name;
  259.     int        exists, i, j, k, tmp1, nat;
  260.     Symbol name, target_type;
  261.     Set names, op_types, array_types;
  262.     Tuple tmp;
  263.     Set tset;
  264.     Node arg, aggregate_node;
  265.     Tuple arg_list;
  266.     Symbol n_t;
  267.     Node lit_name;
  268.     Symbol n;
  269.     Node op_node, args_node;
  270.     Set possible_types;
  271.     Node arg2;
  272.     Symbol nam;
  273.     Node constraint;
  274.     Set ts;
  275.     Symbol t;
  276.     Node ac_expn, type_id;
  277.     Symbol type_mark;
  278.     Symbol desig_type;
  279.     Node c_expr, arg1;
  280.     Node t_node;
  281.     Node e;
  282.     Symbol to_type;
  283.     Set types;
  284.     Node type_node;
  285.     Node low;
  286.     Node high;
  287.     Set t_low, t_high;
  288.     Symbol t1, t2, it, typ;
  289.     Node call_node, index_node;
  290.     Span save_span;
  291.  
  292.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : resolve1 ");
  293.  
  294.     /*if (noop_error ? false) then return; end if; */
  295.     /* TODO: check why noop_error assumed possible non_boolean in above */
  296.     if (noop_error) {
  297.         N_PTYPES(expn) = set_new1((char *) symbol_any);
  298.         return;
  299.     }
  300.  
  301.     op_name = N_KIND(expn);
  302.  
  303.     if (cdebug2 > 3) {
  304. #ifdef IBM_PC
  305.         printf(" resolve1 %p %s\n", expn, kind_str(op_name));
  306. #else
  307.         printf(" resolve1 %ld %s\n", expn, kind_str(op_name));
  308. #endif
  309.     }
  310.  
  311.     switch (op_name) {
  312.     case as_simple_name:
  313.         name = N_OVERLOADED(expn) ? (Symbol) 0 : N_UNQ(expn);
  314.         if (name != (Symbol)0) {
  315.  
  316.             n_t = TYPE_OF(name);
  317.             nat = NATURE(name);
  318.             if ( nat == na_obj
  319.               || nat == na_constant
  320.               || nat == na_in
  321.               || nat == na_inout
  322.               || nat == na_out
  323.               || nat == na_task_obj
  324.               || nat == na_task_obj_spec
  325.               || nat == na_task_type
  326.               || nat == na_task_type_spec) {
  327.                 N_PTYPES(expn) = set_new1((char *) n_t);
  328.             }
  329.             else if (nat == na_type || nat == na_subtype
  330.               || nat == na_enum || nat == na_record
  331.               || nat == na_array || nat == na_access) {
  332.                 N_PTYPES(expn) = set_new1((char *) symbol_any);
  333.                 pass1_error_id("Invalid use of type %", name, "4.4", expn);
  334.             }
  335.             else if (nat == na_discriminant) {
  336.                 /* A discriminant reference can only appear within a  */
  337.                 /* record definition. The rec.type in noted on the node. */
  338.                 save_span = get_left_span(expn);
  339.                 N_KIND(expn) = as_discr_ref;
  340.                 N_AST1(expn) = new_name_node(SCOPE_OF(name));
  341.                 N_AST2(expn) = N_AST4(expn) = (Node) 0;
  342.                 set_span(N_AST1(expn), save_span);
  343.                 N_PTYPES(expn) = set_new1((char *) n_t);
  344.             }
  345.  
  346.             else if (nat == na_void) {
  347.                 N_PTYPES(expn) = set_new1((char *)symbol_any);
  348.                 pass1_error_id("premature use of %", name, "8.3", expn);
  349.                 return;
  350.             }
  351.             else {
  352.                 N_PTYPES(expn) = set_new1((char *) symbol_any);
  353.                 pass1_error_id("Invalid use of identifier %", name, 
  354.                   "4.4", expn);
  355.             }
  356.         }
  357.         else {
  358.             /* The simple name is overloaded: case of a literal or para-*/
  359.             /* meterless function. Reformat with null param. list.*/
  360.             lit_name = copy_node(expn);
  361.             args_node = node_new(as_list);
  362.             N_LIST(args_node) = tup_new(0);
  363.             N_KIND(expn) = as_call;
  364.             N_AST1(expn) = lit_name;
  365.             N_AST2(expn) = args_node;
  366.             resolve1(expn);
  367.         }
  368.         break;
  369.     case as_character_literal:
  370.         N_PTYPES(expn) = set_new(set_size(N_NAMES(expn)));
  371.         FORSET(n = (Symbol), N_NAMES(expn), fs1);
  372.             N_PTYPES(expn) = set_with(N_PTYPES(expn), (char *) TYPE_OF(n));
  373.         ENDFORSET(fs1);
  374.         break;
  375.     case as_op:
  376.     case as_un_op:
  377.     case as_call:
  378.         /* Overloaded constructs. */
  379.  
  380.         op_node = N_AST1(expn);
  381.         args_node = N_AST2(expn);
  382.  
  383.         FORTUP(arg = (Node), N_LIST(args_node), ft1);
  384.             resolve1(arg);
  385.             check_range_attribute(arg);   /* a no-no */
  386.         ENDFORTUP(ft1);
  387.         names = N_NAMES(op_node);
  388.         result_types(expn);
  389.         if (noop_error);    /* Previous error. */
  390.         else if (set_size(N_PTYPES(expn)) == 0)
  391.             type_error(names, (Symbol) 0, 0, expn);
  392.  
  393.         /* All other cases are basic operations on arrays, record, aggregates */
  394.         /* attributes, subtypes, conversions and qualifications. */
  395.         break;
  396.     case as_name:
  397.         find_old(expn);
  398.         resolve1(expn);
  399.         break;
  400.     case as_int_literal:
  401.         N_PTYPES(expn) = set_new1((char *)symbol_universal_integer);
  402.         break;
  403.     case as_real_literal:
  404.         N_PTYPES(expn) = set_new1((char *) symbol_universal_real);
  405.         break;
  406.     case as_string_literal:
  407.         N_PTYPES(expn) = set_new1((char *) symbol_string_type);
  408.         break;
  409.     case as_null:
  410.         N_PTYPES(expn) = find_access_types();
  411.         break;
  412.     case as_aggregate:
  413.         /* Verify that the list    of choices  is properly formatted, and
  414.          * collect  all possible aggregate  types. The types of the in-
  415.          * dividual choices are not used to resolve the aggregate type.
  416.          */
  417.         arg_list = N_LIST(expn);
  418.         exists = FALSE;
  419.         FORTUPI(arg = (Node), arg_list, i, ft1);
  420.             if (N_KIND(arg) == as_choice_list) {
  421.                 exists = TRUE;
  422.                 break;
  423.             }
  424.         ENDFORTUP(ft1);
  425.         if (exists) {
  426.             exists = FALSE;
  427.             for (j = i + 1; j <= tup_size(arg_list); j++) {
  428.                 arg2 = (Node) arg_list[j];
  429.                 if (N_KIND(arg2) != as_choice_list) {
  430.                     exists = TRUE;
  431.                     break;
  432.                 }
  433.             }
  434.         }
  435.         /*    if (exists arg = arg_list(i) | N_KIND(arg) = as_choice_list)
  436.          *    and(exists arg2 in arg_list(i+1..) |
  437.          *     N_KIND(arg2) /= as_choice_list)
  438.          */
  439.         if (exists) {
  440.             Tuple t, t1;
  441.             pass1_error(
  442.               "positional associations must appear first in aggregate", "4.3",
  443.               arg2);
  444.             t = tup_new(i);
  445.             /* N_LIST(expn) = N_LIST(expn)(1..i); */
  446.             t1 = N_LIST(expn);
  447.             for (j = 1; j <= i; j++)
  448.                 t[i] = t1[i];
  449.             N_LIST(expn) = t;
  450.         }
  451.         /* collect all possible aggregate types. */
  452.         N_PTYPES(expn) = find_agg_types();
  453.         break;
  454.     case as_index:
  455.         possible_types = set_new(0);
  456.         {
  457.             Symbol t;
  458.             FORSET(t = (Symbol), valid_array_expn(expn), fs1);
  459.                 possible_types = set_with(possible_types, 
  460.                   (char *) component_type(t));
  461.             ENDFORSET(fs1);
  462.         }
  463.         if (set_size(possible_types) == 0)
  464.             pass1_error("type mismatch in indexing", "4.1.1", expn);
  465.         N_PTYPES(expn) = possible_types;
  466.         break;
  467.     case as_slice:
  468.         /* Slicing operations are equivalent to indexing operations,
  469.          * for type checking purposes. We simply reformat the result
  470.          * of type checking, so that the result type of the slice is
  471.          * the base type of the array expression. If this type is an
  472.          * access type, we must of course dereference it.
  473.          */
  474.         possible_types = valid_array_expn(expn);
  475.  
  476.         if (set_size(possible_types) == 0)
  477.             pass1_error("type mismatch in slice", "4.1.2", expn);
  478.  
  479.         /* N_PTYPES(expn) := {base_type(t)  : t in possible_types}; */
  480.         tset = set_new(0);
  481.         {
  482.             Symbol t;
  483.             FORSET(t = (Symbol), possible_types, fs1);
  484.                 tset = set_with(tset, (char *) t);
  485.             ENDFORSET(fs1);
  486.         }
  487.         set_free(possible_types);
  488.         N_PTYPES(expn) = tset;
  489.         break;
  490.     case as_selector:
  491.         valid_selected_expn(expn);
  492.         break;
  493.     case as_in:
  494.     case as_notin:
  495.         /* The second argument of membership operators is a type_mark or */
  496.         /* a range. */
  497.         op_node = N_AST1(expn);
  498.         args_node = N_AST2(expn);
  499.         tmp = N_LIST(args_node);
  500.         arg1 = (Node) tmp[1];
  501.         arg2 = (Node) tmp[2];
  502.  
  503.         resolve1(arg1);
  504.         if (N_KIND(arg2) == as_range_expression) {
  505.             find_old(arg2);
  506.             k = N_KIND(arg2);
  507.             if (k != as_simple_name && k != as_attribute) {
  508.                 pass1_error("invalid argument for membership operator",
  509.                   "4.4", arg2);
  510.                 return;
  511.             }
  512.             nam = N_UNQ(arg2);
  513.             t = base_type(nam);
  514.             if (in_priv_types(t)) t = nam;
  515.             N_PTYPES(arg2) = set_new1((char *) t);
  516.             /* Missing: range attribute. */
  517.         }
  518.         else {
  519.             if (N_KIND(arg2) != as_attribute) {
  520.                 /* Argument is a range: reformat as subtype of some type. */
  521.                 constraint = copy_node(arg2);
  522.                 N_KIND(arg2) = as_subtype;
  523.                 N_AST1(arg2) = OPT_NODE;
  524.                 N_AST2(arg2) = constraint;
  525.             }
  526.             resolve1(arg2);
  527.  
  528.             /* ts := {t in N_PTYPES(arg2) | is_scalar_type(t)}; */
  529.             ts = set_new(0);
  530.             {
  531.                 Symbol t;
  532.                 FORSET(t = (Symbol), N_PTYPES(arg2), fs1);
  533.                     if (is_scalar_type(t))
  534.                         ts = set_with(ts, (char *) t);
  535.                 ENDFORSET(fs1);
  536.             }
  537.             if (set_size(ts) == 0) {
  538. #ifdef ERRNUM
  539.                 errmsgn(234, 235, arg2);
  540. #else
  541.                 errmsg("bounds of range for membership op must be scalar",
  542.                   "4.4", arg2);
  543. #endif
  544.             }
  545.             else N_PTYPES(arg2) = ts;
  546.         }
  547.         /* Now resolve the expression as for any other operator. */
  548.  
  549.         {
  550.             Set  op_name_set;
  551.             N_KIND(expn) = as_op;
  552.             op_name_set = op_name == as_in ? set_new1((char *)symbol_in)
  553.               : set_new1((char *)symbol_notin);
  554.             N_NAMES(op_node) = op_name_set;
  555.             result_types(expn);
  556.             if (noop_error);
  557.             else if (set_size(N_PTYPES(expn)) == 0)
  558.                 type_error(op_name_set, (Symbol)0, 0, expn);
  559.         }
  560.         break;
  561.     case as_all:
  562.         /* dereference operations must apply  to objects     of access type.
  563.          * The type yielded is obtained by dereferencing the type descrip
  564.          * tor of the access object.
  565.          */
  566.         ac_expn = N_AST1(expn);
  567.  
  568.         resolve1(ac_expn);
  569.         /* ??possible_types := {designated_type(t): t in N_PTYPES(ac_expn)
  570.          *      | is_access(t)};
  571.          */
  572.         possible_types = set_new(0);
  573.         {
  574.             Symbol t;
  575.             FORSET(t = (Symbol), N_PTYPES(ac_expn), fs1);
  576.                 if (is_access(t))
  577.                     possible_types = set_with(possible_types,
  578.                       (char *) designated_type(t));
  579.             ENDFORSET(fs1);
  580.         }
  581.         if (set_size(possible_types) == 0) {
  582.             pass1_error("Expect access type for dereference",
  583.               "3.8", ac_expn);
  584.         }
  585.         N_PTYPES(expn) = possible_types;
  586.         break;
  587.     case as_new:
  588.         /* the elaboration of the subtypes may produce additional
  589.          * anonymous types. These are emitted later on (see resolve2)
  590.          * and here are just collected and discarded.
  591.          */
  592.         newtypes = tup_with(newtypes, (char *)tup_new(0));
  593.         desig_type = make_subtype(expn);
  594.         {
  595.             Tuple junk = (Tuple)tup_frome(newtypes);
  596.             tup_free(junk);
  597.         }
  598.         type_id = N_AST1(expn);
  599.         constraint = N_AST2(expn);
  600.  
  601.         type_mark = N_UNQ(type_id);
  602.         if ((constraint == OPT_NODE) &&(is_unconstrained(type_mark))) {
  603.             pass1_error_l("Constraint required in allocator when",
  604.               "initialization is absent", "4.8", expn);
  605.             return;
  606.         }
  607.         else  /* use name of generated subtype to label allocator */
  608.             N_UNQ(type_id) = desig_type;
  609.  
  610.         check_fully_declared(desig_type);
  611.  
  612.         /* Rebuild node as having a designated type and no aggregate. */
  613.         if (constraint != OPT_NODE) {
  614.             type_node = copy_node(expn);
  615.             N_UNQ(type_node) = desig_type;
  616.             N_KIND(type_node) = as_subtype_decl;
  617.         }
  618.         else type_node = type_id;
  619.         N_AST1(expn) = type_node;
  620.         N_AST2(expn) = OPT_NODE;
  621.  
  622.         /* N_PTYPES(expn) := {a in find_access_types() |
  623.          *    compatible_types(desig_type, designated_type(a))};
  624.          */
  625.         {
  626.             Set s;
  627.             Symbol a;
  628.             s = set_new(0);
  629.             FORSET(a = (Symbol), find_access_types(), fs1);
  630.                 if (compatible_types(desig_type, designated_type(a)))
  631.                     s = set_with(s, (char *) a);
  632.             ENDFORSET(fs1);
  633.             N_PTYPES(expn) = s;
  634.         }
  635.         break;
  636.     case as_new_init:
  637.         /* Allocator given by a type mark and an explicit aggregate. */
  638.  
  639.         type_id = N_AST1(expn);
  640.         aggregate_node = N_AST2(expn);
  641.         find_type(type_id);
  642.         desig_type = N_UNQ(type_id);
  643.         if (!is_type(desig_type)) {
  644.             pass1_error("invalid type mark in allocator", "4.8", type_id);
  645.             return;
  646.         }
  647.         else
  648.             if (is_limited_type(desig_type)) {
  649.                 pass1_error_l("initial value not allowed on an ",
  650.                   "allocator for a limited type", "7.4.4", type_id);
  651.                 return;
  652.             }
  653.         if (N_KIND(aggregate_node) == as_parenthesis) {
  654.             /*Remove parenthesis which is an artifact of parsing.*/
  655.             aggregate_node = N_AST1(aggregate_node);
  656.             N_AST2(expn) = aggregate_node;
  657.         }
  658.         resolve1(aggregate_node);
  659.         /* ??N_PTYPES(expn) = {a in find_access_types() |
  660.          *     compatible_types(desig_type, designated_type(a))}; $$ES151
  661.          */
  662.         {
  663.             Symbol a;
  664.             Set s;
  665.             s = set_new(0);
  666.             FORSET(a = (Symbol), find_access_types(), fs1);
  667.                 if (compatible_types(desig_type, designated_type(a)))
  668.                     s = set_with(s, (char *) a);
  669.             ENDFORSET(fs1);
  670.             N_PTYPES(expn) = s;
  671.         }
  672.         N_KIND(expn) = as_new; /* for common processing. */
  673.         break;
  674.     case as_choice_list:
  675.         /* This is used only for the arguments to calls and not for */
  676.         /* aggregates which are handled in complete_r_aggregate. */
  677.  
  678.         c_expr = N_AST2(expn);
  679.         resolve1(c_expr);
  680. #ifdef TBSL
  681.         -- is copy of N_TYPES needed below    ds 8-jan-85
  682. #endif
  683.         N_PTYPES(expn) = N_PTYPES(c_expr);
  684.         break;
  685.     case as_attribute:
  686.         resolv_attr(expn);
  687.         break;
  688.     case as_qual_range:
  689.         /* When qual_range appears in an expression, the bounds have */
  690.         /* been type-checked. Simple extract the known result type. */
  691.         N_PTYPES(expn) = set_new1((char *) N_TYPE(expn));
  692.         break;
  693.     case as_convert:
  694.         /* The result type is the type mark of the conversion. */
  695.  
  696.         t_node = N_AST1(expn);
  697.         arg = N_AST2(expn);
  698.         tmp1 = N_KIND(arg);
  699.         target_type = N_UNQ(t_node);
  700.         if (tmp1 == as_null || tmp1 == as_new || tmp1 == as_new_init
  701.           || tmp1 == as_aggregate || tmp1 == as_string_literal) {
  702.             pass1_error("invalid expression for conversion", 
  703.               "4.6(3)", arg);
  704.             return;
  705.         }
  706.         else if (is_incomplete_type(target_type)) {
  707.             pass1_error("premature use of private type in expression",
  708.               "7.4.1(4)", t_node);
  709.         }
  710.         else {
  711.             resolve1(arg);
  712.             N_PTYPES(expn) = set_new1((char *)target_type);
  713.         }
  714.         break;
  715.     case as_qualify:
  716.  
  717.         t_node = N_AST1(expn);
  718.         arg = N_AST2(expn);
  719.         to_type = N_UNQ(t_node);
  720.         if (!is_type(to_type)) {
  721.             pass1_error("Expect type mark in qualified expression", 
  722.               "4.7", t_node);
  723.             return;
  724.         }
  725.         else if (in_open_scopes(to_type) && is_task_type(to_type)) {
  726.             pass1_error_id("invalid use of type % within its own body",
  727.               to_type, "9.1", t_node);
  728.             return;
  729.         }
  730.         else if (is_incomplete_type(to_type)) {
  731.             pass1_error("premature use of private type in expression",
  732.               "7.4.1(4)", t_node);
  733.             return;
  734.         }
  735.         else N_PTYPES(expn) = set_new1((char *) to_type);
  736.  
  737.         resolve1(arg);
  738.  
  739.         if (noop_error) return;
  740.         else types = N_PTYPES(arg);
  741.  
  742.         exists = FALSE;
  743.         {
  744.             Symbol t;
  745.             FORSET(t = (Symbol), types, fs1);
  746.                 if (compatible_types(to_type, t)) {
  747.                     exists = TRUE;
  748.                     break;
  749.                 }
  750.             ENDFORSET(fs1);
  751.         }
  752.         if (!exists) {
  753.             pass1_error("Expression has wrong type for qualification",
  754.               "4.7", arg);
  755.         }
  756.         break;
  757.     case as_subtype:
  758.         /* For a subtype expression, the bounds expressions  must  be
  759.          * checked against the specified type, if any, or against the
  760.          * type required by context.
  761.          */
  762.         type_node = N_AST1(expn);
  763.         constraint = N_AST2(expn);
  764.         if (N_KIND(constraint) == as_attribute)
  765.             t_low = t_high = N_PTYPES(constraint);
  766.         else {
  767.             low = N_AST1(constraint);
  768.             high = N_AST2(constraint);
  769.             resolve1(low);
  770.             resolve1(high);
  771.             t_low = N_PTYPES(low);
  772.             t_high = N_PTYPES(high);
  773.         }
  774.         if (type_node == OPT_NODE) {
  775.             /* Case of a range expression with no named type. Validate
  776.              * the bounds against each other, and return the possible types.
  777.              */
  778.             possible_types = set_new(0);
  779.             FORSET(t1 = (Symbol), t_low, fs1);
  780.                 FORSET(t2 = (Symbol), t_high, fs2);
  781.                     it = intersect_types(t1, t2);
  782.                     if (it != (Symbol)0) 
  783.                         possible_types = set_with(possible_types, (char *)it);
  784.                 ENDFORSET(fs2);
  785.             ENDFORSET(fs1);
  786.         }
  787.         else {
  788.             int exists1, exists2;
  789.             /* Subtype of a specified type. Validate the bounds against */
  790.             /* it. */
  791.             typ = N_UNQ(type_node);
  792.             possible_types = set_new1((char *) typ);
  793.             /* if (not exists t1 in t_low |compatible_types(typ, t1))
  794.              *  or (not exists t2 in t_high|compatible_types(typ, t2)) then
  795.              */
  796.             exists1 = exists2 = FALSE;
  797.             FORSET(t1 = (Symbol), t_low, fs1);
  798.                 if (compatible_types(typ, t1)) {
  799.                     exists1 = TRUE;
  800.                     break;
  801.                 }
  802.             ENDFORSET(fs1);
  803.             if (exists1 == TRUE) {
  804.                 FORSET(t2 = (Symbol), t_high, fs1);
  805.                     if (compatible_types(typ, t2)) {
  806.                         exists2 = TRUE;
  807.                         break;
  808.                     }
  809.                 ENDFORSET(fs1);
  810.             }
  811.             if (!exists1 || !exists2) {
  812.                 pass1_error("Invalid types in bounds for range",
  813.                   "3.5, 4.1.2", expn);
  814.             }
  815.         }
  816.         N_PTYPES(expn) = possible_types;
  817.         break;
  818.     case as_parenthesis:
  819.         /* A parenthesised  expression carries  a special operator, in
  820.          * order to distinguish it from a variable.(Thus(X) is not a
  821.          * valid OUT parameter for a procedure, and(D) is not a valid
  822.          * use of a discriminant name).
  823.          */
  824.         e = N_AST1(expn);
  825.         resolve1(e);
  826.         N_PTYPES(expn) = N_PTYPES(e);
  827.         break;
  828.     case as_call_or_index:
  829.         /* A call to a parameterless function that returns an array can
  830.          * overload a call  to a function  call with arguments. Resolve
  831.          * each of the trees independently.
  832.          */
  833.         call_node = N_AST1(expn);
  834.         index_node = N_AST2(expn);
  835.         op_node = N_AST1(call_node);
  836.         args_node = N_AST2(call_node);
  837.         FORTUP(arg = (Node), N_LIST(args_node), ft1);
  838.             resolve1(arg);
  839.         ENDFORTUP(ft1);
  840.         result_types(call_node);
  841.         op_types = N_PTYPES(call_node);
  842. #ifdef TBSN
  843.         if (cdebug2 > 3) TO_ERRFILE('op_types ' + str op_types);
  844. #endif
  845.         array_types = set_new(0);
  846.         FORSET(t = (Symbol), valid_array_expn(index_node), fs1);
  847.             t = (Symbol)component_type(t);
  848.             array_types = set_with(array_types, (char *)t);
  849.         ENDFORSET(fs1);
  850.         N_PTYPES(index_node) = array_types;
  851. #ifdef TBSN
  852.         if (cdebug2 > 3) TO_ERRFILE('array_types ' + str array_types);
  853. #endif
  854.         N_PTYPES(expn) = set_union(op_types, array_types);
  855.         break;
  856.     case as_range:    /* A frequent error. */
  857.         pass1_error("Invalid use of discrete range  in expression",
  858.           "4.4", expn);
  859.         N_PTYPES(expn) = set_new1((char *) symbol_any);
  860.         break;
  861.     default:
  862.         /* TBSL: in SETL have op_name = om: use 0 for now */
  863.         if (op_name == 0) {
  864.             /* usually a previous error; often an invalid selected */
  865.             /*  component name. */
  866.             noop_error = TRUE;
  867.         }
  868.         else 
  869.             pass1_error("Invalid operator in expression: ", "4.4, 4.5", expn);
  870.         break;
  871.     }
  872. }
  873.  
  874. void resolv_attr(Node expn)                                  /*;resolv_attr*/
  875. {
  876.     Fortup ft1;
  877.     int        exists, i, j, notexists, nat, attrkind;
  878.     Symbol s1, s;
  879.     Node entry_node;
  880.     Symbol range_typ;
  881.     Node arg2;
  882.     Node  a_node, arg1;
  883.     Symbol type1;
  884.     Node task_node;
  885.     Symbol task, entry_name;
  886.     Set task_types;
  887.     Node index_node;
  888.     static int is_attribute_prefix = FALSE;
  889.  
  890.     a_node = N_AST1(expn);
  891.     arg1 = N_AST2(expn);
  892.     arg2 = N_AST3(expn);
  893.     if (N_KIND(a_node) == as_simple_name)  /* no attribute if simple name here*/
  894.         attrkind = ATTR_any;
  895.     else
  896.         attrkind = (int) attribute_kind(expn); /* numeric code for attribute */
  897.  
  898.     /* verify that BASE appears only as the prefix of another attribute */
  899.     if (attrkind == ATTR_BASE && !is_attribute_prefix)
  900. #ifdef ERRNUM
  901.         errmsgn(236, 233, expn);
  902. #else
  903.         errmsg("Invalid use of attribute BASE", "Annex A", expn);
  904. #endif
  905.     is_attribute_prefix = TRUE;
  906.  
  907.     /* First - for attributes applying to objects or types, change
  908.      * attrkind to reflect the type of entity to which the attribute
  909.      * is being applied.
  910.      */
  911.     if ( attrkind == ATTR_FIRST || attrkind == ATTR_LAST
  912.       || attrkind == ATTR_RANGE || attrkind == ATTR_LENGTH
  913.       || attrkind == ATTR_SIZE || attrkind == ATTR_CONSTRAINED) 
  914.             attrkind = (int)(attribute_kind(expn) +=(is_type_node(arg1) ? 2:1)); 
  915.  
  916.     /* We find the type of the left argument of the attribute. */
  917.     /* It may be a type name, in which case there is nothing to be */
  918.     /* done. */
  919.  
  920.     if (is_type_node(arg1)) {
  921.         type1 = N_UNQ(arg1);
  922.         if (is_incomplete_type(type1)) {
  923.             premature_access(type1, arg1);
  924.             N_PTYPES(expn) = set_new1((char *) symbol_any);
  925.             return;
  926.         }
  927.         if (is_task_type(type1)
  928.           &&(attrkind != ATTR_BASE
  929.           && attrkind != ATTR_O_SIZE && attrkind != ATTR_T_SIZE
  930.           && attrkind != ATTR_STORAGE_SIZE)) {
  931.             /* may refer to current task */
  932.             if (in_open_scopes(type1))
  933.                 N_UNQ(arg1) = dcl_get(DECLARED(type1), "current_task");
  934.             else
  935.                 /* use of the task type otherwise is invalid.*/
  936.                 pass1_error("invalid use of task type outside of it own body", 
  937.                   "9.1", arg1);
  938.         }
  939.         N_PTYPES(arg1) = set_new1((char *) type1);
  940.     }
  941.     else if (attrkind == ATTR_COUNT) {
  942.         find_entry_name(arg1);
  943.         task_node = N_AST1(arg1);
  944.         entry_node = N_AST2(arg1);
  945.         task_types = N_PTYPES(task_node);
  946.  
  947.         if (entry_node == OPT_NODE || set_size(task_types) == 0) {
  948.             /* previous error*/
  949.             noop_error = TRUE; 
  950.             return;
  951.         }
  952.  
  953.         if (N_KIND(arg1) == as_entry_family_name) {
  954.             entry_name = N_UNQ(entry_node);
  955.             index_node = N_AST3(arg1);
  956.             range_typ = (Symbol) index_type(TYPE_OF(entry_name));
  957.             check_type(range_typ, index_node);
  958.             N_KIND(arg1) = as_entry_name; /* for common processing */
  959.         }
  960.         else {   /* single entry, possibly overloaded */
  961.             if (set_size(N_NAMES(arg1)) > 1) {
  962. #ifdef ERRNUM
  963.                 errmsgn(237, 238, entry_node);
  964. #else
  965.                 errmsg("ambiguous entry name for attribute", "9.9", entry_node);
  966. #endif
  967.                 return;
  968.             }
  969.             else {
  970.                 entry_name = (Symbol) set_arb(N_NAMES(arg1));
  971.                 N_UNQ(entry_node) = entry_name;
  972.                 N_AST3(arg1) = OPT_NODE; /* discard N_NAMES */
  973.             }
  974.         }
  975.         complete_task_name(task_node, TYPE_OF(SCOPE_OF(entry_name)));
  976.         task= N_UNQ(task_node);
  977.  
  978.         /* The COUNT attribute can only be used immediately within*/
  979.         /* the object executing the task body. */
  980.         exists = FALSE;
  981.         if (N_KIND(task_node) != as_simple_name) exists = TRUE;
  982.         if (!exists) {
  983.             /* check that the task is one of the open scopes */
  984.             notexists = TRUE;
  985.             FORTUPI(s = (Symbol), open_scopes, i, ft1);
  986.                 s = (Symbol) open_scopes[i];
  987.                 if (task == s 
  988.                   || strcmp(original_name(task), "current_task") == 0
  989.                   && SCOPE_OF(task) == s) {
  990.                     notexists = FALSE;
  991.                     break;
  992.                 }
  993.             ENDFORTUP(ft1);
  994.             if (notexists) exists = TRUE; /* not in open scopes */
  995.         }
  996.         if (!exists) {
  997.             /* intervening scopes cannot be subprograms, etc */
  998.             for (j = 1; j <= i-1; j++) {
  999.                 s1 = (Symbol) open_scopes[j];
  1000.                 nat = NATURE(s1);
  1001.                 if (nat != na_block && nat != na_entry 
  1002.                   && nat != na_entry_family) {
  1003.                     exists = TRUE;
  1004.                     break;
  1005.                 }
  1006.             }
  1007.         }
  1008.         if (exists) {
  1009.             pass1_error_l( "E\'COUNT can only be used within the body ",
  1010.               "of the task containing E", "9.9", expn);
  1011.             return;
  1012.         }
  1013.  
  1014.         type1 = symbol_none;
  1015.         N_PTYPES(arg1) = set_new1((char *) symbol_none);
  1016.     }
  1017.     else {
  1018.         resolve1(arg1);
  1019.         if (set_size(N_PTYPES(arg1)) != 1) {
  1020.             pass1_error_str("Invalid argument for attribute %",
  1021.               attribute_str(attrkind), "Annex A, 4.1.4", expn);
  1022.             return;
  1023.         }
  1024.         else
  1025.             type1 = (Symbol) set_arb(N_PTYPES(arg1));
  1026.     }
  1027.  
  1028.     is_attribute_prefix = FALSE;   /* clear flag */
  1029.  
  1030.     /* Verify that the type has received a full declaration. */
  1031.     if (is_incomplete_type(type1)) {
  1032.         /* 'SIZE and 'ADDRESS can be applied to a deffered constant,
  1033.          * in the default expression for record components and non-
  1034.          * generic formal parameters. The nature of the current scope
  1035.          * is either na_record or na_void(formal part or discr. part).
  1036.          */
  1037.         if (!is_type_node(arg1) &&
  1038.           (attrkind == ATTR_O_SIZE || attrkind == ATTR_T_SIZE
  1039.           || attrkind == ATTR_ADDRESS) &&(NATURE(scope_name) == na_void
  1040.           || NATURE(scope_name) == na_record)) {
  1041.             ;
  1042.         }
  1043.         else {
  1044.             premature_access(type1, arg1);
  1045.             N_PTYPES(expn) = set_new1((char *) symbol_any);
  1046.             return;
  1047.         }
  1048.     }
  1049.     /* Verify that attributes have the proper number of arguments. */
  1050.  
  1051.     if (is_scalar_type(type1) &&
  1052.       (  attrkind == ATTR_O_FIRST || attrkind == ATTR_T_FIRST
  1053.       || attrkind == ATTR_O_LAST || attrkind == ATTR_T_LAST)) {
  1054.         if (arg2 != OPT_NODE) {
  1055.             pass1_error_str("Invalid second argument for attribute %",
  1056.               attribute_str(attrkind), "Annex A, 4.1.4", arg2);
  1057.         }
  1058.         else if ((N_KIND(arg1) == as_simple_name &&(!is_type(N_UNQ(arg1))))
  1059.           || (N_KIND(arg1) == as_attribute
  1060.           && (int) attribute_kind(arg1) != ATTR_BASE)) {
  1061.             pass1_error("attribute cannot be applied to scalar object",
  1062.               "Annex A", a_node);
  1063.         }
  1064.     }
  1065.     else if (attrkind == ATTR_POS 
  1066.       || attrkind == ATTR_VAL 
  1067.       || attrkind == ATTR_PRED 
  1068.       || attrkind == ATTR_SUCC 
  1069.       || attrkind == ATTR_VALUE 
  1070.       || attrkind == ATTR_IMAGE) {
  1071.         if (arg2 == OPT_NODE) {
  1072.             pass1_error("Missing second argument for attribute ",
  1073.               "Annex A", a_node);
  1074.             return;
  1075.         }
  1076.         else
  1077.             if (!is_type_node(arg1) || (N_KIND(arg1) == as_attribute
  1078.               && (int) attribute_kind(arg1) == ATTR_BASE)) {
  1079.                 pass1_error_l("First argument of attribute must ",
  1080.                   "be a type mark", "Annex A", a_node);
  1081.                 return;
  1082.             }
  1083.     }
  1084.  
  1085.     /* In the case of array attributes, the argument may be an access */
  1086.     /*    object. Dereference it now. */
  1087.     if ((attrkind == ATTR_O_FIRST || attrkind == ATTR_T_FIRST 
  1088.       || attrkind == ATTR_O_LAST || attrkind == ATTR_T_LAST 
  1089.       || attrkind == ATTR_O_RANGE || attrkind == ATTR_T_RANGE 
  1090.       || attrkind == ATTR_O_LENGTH || attrkind == ATTR_T_LENGTH)
  1091.       && is_access(type1)
  1092.       && is_array((Symbol)(designated_type(type1)))) {
  1093.         if (is_fully_private(type1)) {
  1094.             premature_access(type1, arg1);
  1095.             N_PTYPES(expn) = set_new1((char *)symbol_any);
  1096.             return;
  1097.         }
  1098.         dereference_node(arg1, type1);
  1099.         type1 = (Symbol) designated_type(type1);
  1100.     }
  1101.     else if ((attrkind == ATTR_CALLABLE || attrkind == ATTR_TERMINATED)
  1102.       && is_access(type1)) {
  1103.         dereference_node(arg1, type1);
  1104.         type1 = (Symbol) designated_type(type1);
  1105.     }
  1106.  
  1107.     if (arg2 == OPT_NODE) {
  1108.         /* For array attributes, a missing second argument is */
  1109.         /* equivalent to a reference to the first dimension. */
  1110.         arg2 = node_new(as_int_literal);
  1111.         set_span(arg2, get_right_span(N_AST2(expn)));
  1112.         N_VAL(arg2) = strjoin("1", "");
  1113.         N_AST3(expn) = arg2;
  1114.     }
  1115.  
  1116.     /* The  procedure  attribute-type  will  resolve  fully arg2 */
  1117.     /* in the case of array attributes, to obtain a dimension no. */
  1118.  
  1119.     N_PTYPES(expn) =
  1120.       set_new1((char *)attribute_type(attrkind, type1, arg1, arg2));
  1121. }
  1122.  
  1123. /* Made case as_attribute in resolve2 into separate procedure 
  1124.  * resolve2_attr.  Having resolve2_attr return (Symbol)0 in case of pass1_error.
  1125.  */
  1126.  
  1127. static void dereference_node(Node arg1, Symbol type1)    /*;dereference_node*/
  1128. {
  1129.     /* the prefix of several attributes must be appropriate for the type,
  1130.      * i.e.  it can be an access to an entity  of the proper kind. This
  1131.      * routine is called to emit an explicit dereference (.all) in such cases.
  1132.      */
  1133.  
  1134.     Node acc_arg1;
  1135.  
  1136.     if (is_type_node(arg1)) {
  1137.         ;    /* no op */
  1138.     }
  1139.     else {    /* Dereference object */
  1140.         acc_arg1 = copy_node(arg1);
  1141.         N_AST2(arg1) = (Node)0;
  1142.         N_AST3(arg1) = (Node)0;
  1143.         N_AST4(arg1) = (Node)0;
  1144.         N_PTYPES(acc_arg1) = set_new1((char *)type1);
  1145.         N_KIND(arg1) = as_all;
  1146.         N_AST1(arg1) = acc_arg1;
  1147.     }
  1148.     N_PTYPES(arg1) = set_new1((char *)designated_type(type1));
  1149. }
  1150.  
  1151. void resolve2(Node expn, Symbol context_typ)                  /*;resolve2*/
  1152. {
  1153.     /* This procedure performs the second, top-down pass of the
  1154.      * type validation and overloading resolution.
  1155.      * second argument is the type which the expression must yield.
  1156.      * If the expression is overloaded, only one of its instances must
  1157.      * yield  -context_typ-. Once this is ascertained, the known types of the
  1158.      *formals for the top level operator in expression, are propagated
  1159.      * downwards to the actuals.
  1160.      */
  1161.  
  1162.     Fortup ft1;
  1163.     Forset fs1;
  1164.     int        exists, nat, nk;
  1165.     Set types, a_types, ntypes;
  1166.     Set oa_types = (Set) 0;
  1167.     Symbol name, type2, c, rtype, target_type, ntype_sym;
  1168.     Node op_node, args_node, node;
  1169.     Set valid_ops;
  1170.     Symbol op_name, atysym, t2;
  1171.     Set op_names;
  1172.     Tuple tup, indices;
  1173.     Symbol target_typ;
  1174.     Node array1;
  1175.     Symbol array_type;
  1176.     int        out_c;
  1177.     Tuple    index_list;
  1178.     Node index;
  1179.     int        i, may_others;
  1180.     Node discr1, e, ac_expn;
  1181.     Symbol access_type;
  1182.     Node type_node, expn1, entry_node;
  1183.     Symbol alloc_type;
  1184.     Symbol accessed_type;
  1185.     /*char   *chk;*/
  1186.     char    *strvstr;
  1187.     Tuple    strvtup;
  1188.     int        strvlen, strvi;
  1189.     Symbol t;
  1190.     Symbol c1, c2;
  1191.     Set tu;
  1192.     Node t_node, constraint, low, high;
  1193.     Symbol b_type;
  1194.     int        kind;
  1195.     Node call_node, index_node;
  1196.     Const    lv; /*TBSL: check type of lv */
  1197.     char    *orignam;
  1198.     Tuple    litmaptup;
  1199.     int        litmapi;
  1200.     Span    save_span;
  1201.  
  1202.     if (cdebug2 > 0) {
  1203.         TO_ERRFILE("resolve2 ");
  1204. #ifdef IBM_PC
  1205.         printf(" %p %s context %p %s\n"
  1206.           , expn, kind_str(N_KIND(expn)), context_typ,
  1207.           ((context_typ != (Symbol)0)? ORIG_NAME(context_typ):""));
  1208. #else
  1209.         printf(" %ld %s context %ld %s\n"
  1210.           , expn, kind_str(N_KIND(expn)), context_typ,
  1211.           ((context_typ != (Symbol)0)? ORIG_NAME(context_typ):""));
  1212. #endif
  1213.     }
  1214.     if (context_typ == (Symbol)0)
  1215.         printf("??:resolve2 context_typ null\n");
  1216.     if (noop_error) return;
  1217.  
  1218.     types = N_PTYPES(expn);
  1219.  
  1220.     if (expn == OPT_NODE) return;
  1221.  
  1222.     switch (nk = N_KIND(expn)) {
  1223.     case as_simple_name:
  1224.         name = N_UNQ(expn);
  1225.         /* If constant, get its value, and if universal constant,
  1226.          * convert when necessary.
  1227.          */
  1228.         type2 = TYPE_OF(name);
  1229.         if (!compatible_types(context_typ, type2)) {
  1230. #ifdef ERRNUM
  1231.             id_type_errmsgn(239, name, context_typ, 10, expn);
  1232. #else
  1233.             errmsg_id_type("% has incorrect type. Expect %", name, context_typ,
  1234.               "none", expn);
  1235. #endif
  1236.             noop_error = TRUE;
  1237.             return;
  1238.         }
  1239.         else
  1240.             if ((NATURE(name) == na_out) &&(!out_context)) {
  1241. #ifdef ERRNUM
  1242.                 id_errmsgn(240, name, 241, expn);
  1243. #else
  1244.                 errmsg_id("invalid reading of out parameter %", name, "6.2",
  1245.                   expn);
  1246. #endif
  1247.             }
  1248.         if (NATURE(name) == na_constant) {
  1249.             if (in_univ_types(type2)) {
  1250.                 copy_attributes((Node) SIGNATURE(name), expn);
  1251.                 specialize(expn, context_typ);
  1252.                 type2 = base_type(context_typ);
  1253.             }
  1254.             else if ((Node) SIGNATURE(name) == OPT_NODE
  1255.               && (NATURE(scope_name) != na_void 
  1256.               && NATURE(scope_name) != na_record)) {
  1257.                 /* Only permissible contexts for a defered constant are
  1258.                  * formal parts and component declarations.
  1259.                  */
  1260. #ifdef ERRNUM
  1261.                 l_errmsgn(242, 243, 43, expn);
  1262. #else
  1263.                 errmsg_l("premature use of deferred constant before its",
  1264.                   "full declaration", "7.4.3", expn);
  1265. #endif
  1266.             }
  1267.         }
  1268.         else eval_static(expn);
  1269.         break;
  1270.     case as_character_literal:
  1271.         exists = FALSE;
  1272.         FORSET(c = (Symbol), N_NAMES(expn), fs1);
  1273.             if (compatible_types(context_typ, TYPE_OF(c))) {
  1274.                 exists = TRUE;
  1275.                 break;
  1276.             }
  1277.         ENDFORSET(fs1);
  1278.         if (exists) {
  1279.             type2 = TYPE_OF(c);
  1280.             /*N_VAL(expn) = literal_map(type2)(original_name(c));*/
  1281.             /* In the C version, create a Const with this value */
  1282.             orignam = ORIG_NAME(c);
  1283.             if (orignam == (char *)0) chaos("resolve2 null literal");
  1284.             litmaptup = (Tuple) literal_map(type2);
  1285.             for (litmapi = 1; litmapi <= tup_size(litmaptup); litmapi += 2) {
  1286.                 if (streq(orignam, litmaptup[litmapi])) {
  1287.                     N_VAL(expn) = (char *) int_const((int)litmaptup[litmapi+1]);
  1288.                     break;
  1289.                 }
  1290.             }
  1291.         }
  1292.         else {
  1293.             char *tmp_msg;
  1294.  
  1295.             tmp_msg = strjoin(N_VAL(expn), " has incorrect type. Expect %");
  1296. #ifdef ERRNUM
  1297.             type1_errmsgn(tmp_msg, context_typ, 10, expn);
  1298. #else
  1299.             errmsg_type(tmp_msg, context_typ, "none", expn);
  1300. #endif
  1301.             type2 = symbol_any;
  1302.             N_VAL(expn) = (char *) int_const(0);
  1303.         }
  1304.         N_KIND(expn) = as_ivalue;
  1305.         N_OVERLOADED(expn) = FALSE;
  1306.         N_PTYPES(expn) = (Set) 0;
  1307.         N_NAMES(expn) = (Set) 0;
  1308.         break;
  1309.     case as_op:
  1310.     case as_un_op:
  1311.     case as_call:
  1312.         op_node = N_AST1(expn);
  1313.         args_node = N_AST2(expn);
  1314.         op_names = N_NAMES(op_node);
  1315.  
  1316.         /* Find instance of operator that yields type imposed by context. */
  1317.         valid_ops = set_new(0);
  1318.         FORSET(name = (Symbol), op_names, fs1);
  1319.             if (compatible_types(context_typ, TYPE_OF(name)))
  1320.                 valid_ops = set_with(valid_ops, (char *) name);
  1321.         ENDFORSET(fs1);
  1322.  
  1323.         N_NAMES(op_node) = valid_ops;
  1324.  
  1325.         if (set_size(valid_ops) > 1)
  1326.             disambiguate(expn, context_typ);
  1327.  
  1328.         if (set_size(N_NAMES(op_node)) > 1)
  1329.             /* try removing implicit conversions of universal quantities. */
  1330.             remove_conversions(expn);
  1331.  
  1332.         /* Now there should be only one possiblity left. */
  1333.         valid_ops = N_NAMES(op_node);
  1334.         if (set_size(valid_ops) != 1) {
  1335.             if (cdebug2 > 2) {
  1336. #ifdef TBSN
  1337.                 ??(for nam in valid_ops)
  1338.                     TO_ERRFILE('OVERLOADS ', nam, SYMBTAB(nam));
  1339.                 end for;
  1340. #endif
  1341.             }
  1342.             type_error(op_names, context_typ, set_size(valid_ops), op_node);
  1343.             return;
  1344.         }
  1345.         else {
  1346.             op_name = (Symbol) set_arb(valid_ops);
  1347.             type2   = TYPE_OF(op_name);
  1348.         }
  1349.  
  1350.         N_OVERLOADED(expn) = FALSE; /* DS -check this */
  1351.         N_NAMES(expn) = N_PTYPES(expn) = (Set)0;
  1352.         /* For a predefined operator, the type imposed by context fixes
  1353.          * the types of the arguments. The signature of a predefined op.
  1354.          * contains only classes of types, and it ignored in this pass.
  1355.          * The resulting type must be that of the context.
  1356.          */
  1357.         switch (nat = NATURE(op_name)) {
  1358.         case na_op:
  1359.             type2 = base_type(context_typ);
  1360.             N_UNQ(op_node) = op_name;
  1361.             complete_op_expr(expn, type2);
  1362.             /* The expression "+"(1, 2) is syntactically a function call. At
  1363.              * this point it recognized as an operator node.
  1364.              */
  1365.             if (N_KIND(expn) == as_call)
  1366.                 N_KIND(expn) = (tup_size(N_LIST(args_node)) == 1) ? as_un_op
  1367.                   : as_op;
  1368.  
  1369.             /* For a procedure or function, the signature imposes a type on
  1370.              * each actual parameter present, and specifies a default value
  1371.              * for the ones that are absent. If the function is aliased(ie
  1372.              * a renaming or derivation) the parent subprogram is called.
  1373.              */
  1374.             break;
  1375.         case na_procedure:
  1376.         case na_procedure_spec:
  1377.         case na_function:
  1378.         case na_function_spec:
  1379.             complete_arg_list(SIGNATURE(op_name), args_node);
  1380.             N_KIND(expn) = as_call;
  1381.             N_UNQ(op_node) = op_name;
  1382.             TO_XREF(op_name);
  1383.             break;
  1384.         case na_entry:
  1385.         case na_entry_family:
  1386.             complete_arg_list(SIGNATURE(op_name), args_node);
  1387.             N_KIND(expn) = as_ecall;
  1388.             if (N_KIND(op_node) == as_entry_name
  1389.               || N_KIND(op_node) == as_entry_family_name) {
  1390.                 entry_node = N_AST2(op_node);
  1391.                 /* Note  the unique name on the entry name node. */
  1392.                 N_UNQ(entry_node) = op_name;
  1393.             }
  1394.             else {   /* called from proc_or_entry, no entry name yet */
  1395.                 N_UNQ(op_node) = op_name;
  1396.             }
  1397.             TO_XREF(op_name);
  1398.  
  1399.             /* Resolved enumeration literals are returned as themselves. */
  1400.             break;
  1401.         case na_literal:
  1402.             save_span = get_left_span(expn);
  1403.             N_KIND(expn) = as_simple_name;
  1404.             N_UNQ(expn)  = op_name;
  1405.             set_span(expn, save_span);
  1406.             N_AST2(expn) = (Node)0; /* clear ast */
  1407.             N_VAL(expn)  = ORIG_NAME(op_name);
  1408.             TO_XREF(op_name);
  1409.             break;
  1410.         }
  1411.         /* Remaining cases are basic operations. */
  1412.         break;
  1413.     case as_int_literal:
  1414.         /* If the context  type is not universal, the literal must be trans-
  1415.          * formed to its short SETL form.
  1416.          */
  1417.         target_typ = ((context_typ == symbol_universal_integer)
  1418.           ? symbol_universal_integer : symbol_integer);
  1419.  
  1420.         lv = adaval(target_typ, N_VAL(expn));
  1421.         if (adaval_overflow)
  1422.             create_raise(expn, symbol_numeric_error);
  1423.         else {
  1424.             ast_clear(expn);
  1425.             N_KIND(expn) = as_ivalue;
  1426.             N_VAL(expn) = (char *) lv;
  1427.         }
  1428.         type2 = base_type(context_typ); /* inherited from context */
  1429.         if (root_type(type2) != symbol_integer
  1430.           && root_type(type2) != symbol_universal_integer) {
  1431. #ifdef ERRNUM
  1432.             errmsgn(244, 245, expn);
  1433. #else
  1434.             errmsg("invalid context for integer literal", "4.6(15)", expn);
  1435. #endif
  1436.         }
  1437.         break;
  1438.     case as_real_literal:
  1439.         /* If the context is not universal, or is not a fixed type, then
  1440.          * convert the literal to a SETL floating number.
  1441.          */
  1442.         target_typ = (context_typ == symbol_universal_real
  1443.           || is_fixed_type(root_type(context_typ)))
  1444.           ? symbol_universal_real: symbol_float;
  1445.         lv = adaval(target_typ, N_VAL(expn));
  1446.         if (adaval_overflow)
  1447.             create_raise(expn, symbol_constraint_error);
  1448.         else {
  1449.             ast_clear(expn);
  1450.             N_KIND(expn) = as_ivalue;
  1451.             N_VAL(expn) = (char *) lv;
  1452.         }
  1453.         type2 = base_type(context_typ); /* inherited from context */
  1454.         if (root_type(type2) != symbol_float 
  1455.           && !is_fixed_type(root_type(type2))
  1456.           && root_type(type2) != symbol_universal_real) {
  1457. #ifdef ERRNUM
  1458.             errmsgn(246, 245, expn);
  1459. #else
  1460.             errmsg("invalid context for real literal", "4.6(15)", expn);
  1461. #endif
  1462.         }
  1463.         break;
  1464.     case as_string_literal:
  1465.         if (is_array(context_typ)) {
  1466.             if (context_typ == symbol_string_type) {
  1467.                 /* verify that only one string type is visible. */
  1468.                 context_typ = symbol_string;
  1469.             }
  1470.             else if (is_fully_private(context_typ))
  1471.                 premature_access(context_typ, expn);
  1472.  
  1473.             if (root_type(context_typ) == symbol_string) {
  1474.                 /*N_VAL(expn) := [abs c: c in N_VAL(expn)];*/
  1475.                 strvstr = N_VAL(expn);
  1476.                 strvlen = strlen(strvstr);
  1477.                 strvtup = tup_new(strvlen);
  1478.                 for (strvi = 1; strvi <= strvlen; strvi++)
  1479.                     strvtup[strvi] = (char *) strvstr[strvi-1];
  1480.                 ast_clear(expn);
  1481.                 N_VAL(expn) = (char *) strvtup;
  1482.                 N_KIND(expn) = as_string_ivalue;
  1483.                 N_NAMES(expn) = (Set) 0;
  1484.             }
  1485.             else {
  1486.                 /* Context is user-defined array of a character type. */
  1487.                 complete_string_literal(expn, component_type(context_typ));
  1488.             }
  1489.         }
  1490.         else {
  1491. #ifdef ERRNUM
  1492.             type_errmsgn(247, context_typ, 10, expn);
  1493. #else
  1494.             errmsg_type("Incorrect type for string literal. Expect %",
  1495.               context_typ, "none", expn);
  1496. #endif
  1497.         }
  1498.         type2 = context_typ;
  1499.         break;
  1500.     case as_null:
  1501.         if (is_access(context_typ)) type2 = context_typ;
  1502.         else {
  1503. #ifdef ERRNUM
  1504.             errmsgn(248, 249, expn);
  1505. #else
  1506.             errmsg("Invalid context for NULL", "3.8.2", expn);
  1507. #endif
  1508.             return;
  1509.         }
  1510.         break;
  1511.     case as_aggregate:
  1512.         /* Resolve it using the  context type, and apply constraint if any.
  1513.          * The possible types include all visible composite types, and there
  1514.          * should be one of them compatible with the context.
  1515.          */
  1516.         exists = FALSE;
  1517.         FORSET(t = (Symbol), types, fs1);
  1518.             if (compatible_types(t, context_typ)) {
  1519.                 exists = TRUE;
  1520.                 break;
  1521.             }
  1522.         ENDFORSET(fs1);
  1523.         if (!exists) {
  1524. #ifdef ERRNUM
  1525.             id_errmsgn(250, context_typ, 251, expn);
  1526. #else
  1527.             errmsg_id("No aggregate available for type %", context_typ, "4.2",
  1528.               expn);
  1529. #endif
  1530.             return;
  1531.         }
  1532.         else complete_aggregate(context_typ, expn);
  1533.  
  1534.         type2 = context_typ;
  1535.  
  1536.         /* in the absence of more precise checks, the type of the
  1537.          * aggregate can only be set to the base type (see end of resolve2
  1538.          */
  1539.         context_typ = base_type (context_typ);
  1540.  
  1541.         /* For arrays, obtain required index type from type of array
  1542.          * expression, and complete the determination of both.
  1543.          */
  1544.         break;
  1545.     case as_index:
  1546.         array1 = N_AST1(expn);
  1547.         index_node = N_AST2(expn);
  1548.  
  1549.         array_type = complete_array_expn(expn, context_typ);
  1550.  
  1551.         /* Previous error*/
  1552.         if (array_type == symbol_any) return;
  1553.         /* Complete resolution of each index.
  1554.          * The  index expression is    a context  in which  out parameters
  1555.          * cannot  be  read. This  has to  be  special-cased     because an
  1556.            * indexed  expression on  the lhs  of an assignment is a  valid
  1557.          * context for an out parameter, and the global flag out_context
  1558.          * is set accordingly in  processing assignments.
  1559.          */
  1560.         out_c = out_context;
  1561.         out_context = FALSE;
  1562.         index_list = N_LIST(index_node);
  1563.  
  1564.         FORTUPI(index = (Node), index_list, i, ft1);
  1565.             resolve2(index, (Symbol) (index_types(array_type))[i]);
  1566.         ENDFORTUP(ft1);
  1567.         out_context = out_c;
  1568.  
  1569.         type2 = (Symbol) component_type(array_type);
  1570.         break;
  1571.     /* For slices, obtain array type, and apply its index type to the
  1572.      * subtype expression for the discrete range.
  1573.      */
  1574.     case as_slice:
  1575.         array1 = N_AST1(expn);
  1576.         index_node = N_AST2(expn);
  1577.         array_type = complete_array_expn(expn, context_typ);
  1578.         /* Previous error*/
  1579.         if (array_type == symbol_any)
  1580.             return;
  1581.         tup = N_LIST(index_node);
  1582.         discr1 = (Node) (tup[1]);
  1583.         resolve2(discr1, (Symbol) index_type(array_type));
  1584.         /*    Replace index list with its sole element. */
  1585.         N_AST2(expn) = discr1;
  1586.         N_AST3(expn) = N_AST4(expn) = (Node) 0;
  1587.         type2 = base_type(array_type);
  1588.         break;
  1589.     case as_selector:
  1590.         type2 = complete_selected_expn(expn, context_typ);
  1591.  
  1592.         /* For a parenthesised expression, resolve the expression, and keep
  1593.          * the parenthesis, to distinguish them from variables. The possible
  1594.          * constraint of the context is not propagated to the expression.
  1595.          * If the context is universal, discard the parenthesis, to enable
  1596.          * full evaluation of universal expressions.
  1597.          */
  1598.         break;
  1599.     case as_parenthesis:
  1600.         e = N_AST1(expn);
  1601.         resolve2(e, base_type(context_typ));
  1602.         if (in_univ_types(context_typ))
  1603.             copy_attributes(e, expn);
  1604.         apply_constraint(e, context_typ);
  1605.         type2 = context_typ;
  1606.         break;
  1607.     /* For a dereference operation, we must verify that the access
  1608.      * object points to the right type.
  1609.      */
  1610.     case as_all:
  1611.         ac_expn = N_AST1(expn);
  1612.         {
  1613.             Symbol t;
  1614.  
  1615.             a_types = set_new(0);
  1616.             FORSET(t = (Symbol), N_PTYPES(ac_expn), fs1);
  1617.                 if (is_access(t)
  1618.                   && compatible_types(context_typ, designated_type(t)))
  1619.                     a_types = set_with(a_types, (char *) t);
  1620.             ENDFORSET(fs1);
  1621.         }
  1622.         /* TBSL: check that t is defined in type_error call dsd 18 aug */
  1623.         if (set_size(a_types) != 1) {
  1624.             remove_conversions(ac_expn);    /* last chance */
  1625.             oa_types = a_types;
  1626.             a_types = set_new(0);
  1627.             FORSET(atysym = (Symbol), N_PTYPES(ac_expn), fs1);
  1628.                 if (set_mem((char *)atysym, oa_types))
  1629.                     a_types = set_with(a_types, (char *) atysym);
  1630.             ENDFORSET(fs1);
  1631.             if (set_size(a_types) != 1) {
  1632. #ifdef TBSL
  1633.                 ]        type_error(set_new1('@'), t, set_size(a_types), expn);
  1634. #endif
  1635.                 set_free(oa_types); 
  1636.                 set_free(a_types);
  1637.                 return;
  1638.             }
  1639.         }
  1640.         access_type = (Symbol) set_arb(a_types);    /* Only one type left. */
  1641.         set_free(a_types);
  1642.         if (oa_types != (Set)0)
  1643.             set_free(oa_types);
  1644.  
  1645.         /* We know already that the nature of access type is na_access. */
  1646.         type2 = (Symbol) designated_type(access_type);
  1647.         /* It is always illegal to dereference an out parameter.*/
  1648.         out_c = out_context;
  1649.         out_context = FALSE;
  1650.         resolve2(ac_expn, access_type);
  1651.         out_context = out_c;
  1652.         break;
  1653.     /* For an allocator, we obtain the type of the access object
  1654.      * by dereferencing the access type. The final expression however
  1655.      * gives the access type, together with the validated access object.
  1656.      */
  1657.     case as_new:
  1658.         type_node = N_AST1(expn);
  1659.         expn1 = N_AST2(expn);
  1660.         alloc_type = N_UNQ(type_node);
  1661.  
  1662.         if (!is_access(context_typ)) {
  1663. #ifdef ERRNUM
  1664.             errmsgn(252, 253, expn);
  1665. #else
  1666.             errmsg("Context of allocator must be an access type", "4.8, 3.8",
  1667.               expn);
  1668. #endif
  1669.             return;
  1670.         }
  1671.  
  1672.         accessed_type = (Symbol) designated_type(context_typ);
  1673.         /* Verify that the allocator matches the context.
  1674.          * The(possibly unconstrained)    access type is    the one given by the
  1675.          * context(eg.    declaration). If the allocator provides a constraint
  1676.          * rather than an aggregate, then a subtype has been created, and the
  1677.          * access type is an access to this constrained type. The  constraint
  1678.          * must     then be  emitted so that it is evaluated at the proper time.
  1679.          *(The subtype is  not an anonymous type, and is introduced  only to
  1680.          * simplify type checking).
  1681.          * The converse may also occur: the  context is     constrained, but the
  1682.          * allocator  type is  unconstrained. In that  case, use  the context
  1683.          * context type as the type of the expression.
  1684.          * Finally,  the context  may be  an unconstrained  array type, whose
  1685.          * index  type    is   nevertheless   bounded.  When   the allocator is
  1686.          * initialized with an aggregate, the bounds of the aggregate must be
  1687.          * compatible with that index type.
  1688.          */
  1689.         if (!compatible_types(accessed_type, alloc_type)) {
  1690. #ifdef ERRNUM
  1691.             type_errmsgn(254, accessed_type, 255, type_node);
  1692. #else
  1693.             errmsg_type("Invalid type for allocator. Expect %", accessed_type,
  1694.               "3.8, 4.8", type_node);
  1695. #endif
  1696.             return;
  1697.         }
  1698.  
  1699.         if (expn1 != OPT_NODE) {
  1700.             res2_check(expn1, alloc_type);
  1701.             if (is_array(accessed_type) && can_constrain(accessed_type)) {
  1702.                 /* bounds of the aggregate will have to be shown to be 
  1703.                  * compatible with the (unconstrained) designated type.
  1704.                  */
  1705.                 make_constrained_node(expn1, accessed_type, as_qual_sub);
  1706.             }
  1707.             else if (!can_constrain(accessed_type)
  1708.               && accessed_type != alloc_type) {
  1709.                 /*A further qualification is necessary.*/
  1710.                 may_others = full_others;
  1711.                 full_others = TRUE;
  1712.                 apply_constraint(expn1, accessed_type);
  1713.                 full_others = may_others;
  1714.             }
  1715.         }
  1716.         else if (is_array(alloc_type) && N_KIND(type_node) == as_subtype_decl) {
  1717.             /* the index subtypes of the type will have to be elaborated. */
  1718.             indices = tup_new(0);
  1719.             { 
  1720.                 Symbol i;
  1721.                 FORTUP(i = (Symbol), index_types(alloc_type), ft1);
  1722.                     indices =
  1723.                       tup_with(indices, (char *) new_subtype_decl_node(i));
  1724.                 ENDFORTUP(ft1);
  1725.             }
  1726.             N_TYPE(expn) = context_typ;
  1727.             make_insert_node(expn, indices, copy_node(expn));
  1728.         }
  1729.  
  1730.         else if (is_access(alloc_type) && N_KIND(type_node) == as_subtype_decl){
  1731.             /* the designated type is anonymous, and will also be elaborated. */
  1732.             indices = tup_new(0);
  1733.             { 
  1734.                 Symbol i, d;
  1735.                 d = (Symbol) designated_type(alloc_type);
  1736.                 if is_array(d) {       /* elaborate indices as well */
  1737.                     FORTUP(i = (Symbol), index_types(d), ft1);
  1738.                         indices =
  1739.                           tup_with(indices, (char *) new_subtype_decl_node(i));
  1740.                     ENDFORTUP(ft1);
  1741.                 }
  1742.                 indices = tup_with(indices, (char *) new_subtype_decl_node(d));
  1743.             }
  1744.             N_TYPE(expn) = context_typ;
  1745.             make_insert_node(expn, indices, copy_node(expn));
  1746.         }
  1747.         type2 = context_typ;/* No further constraints */
  1748.         break;
  1749.     /* For an attribute, we complete the type checking of the right
  1750.      * argument, and if it must be a static expression, we perform
  1751.      * the appropriate check and extract the attribute.
  1752.      */
  1753.     case as_attribute:
  1754.     case as_range_attribute:
  1755.         type2 = resolve2_attr(expn, context_typ);
  1756.         /* return immediately if resolve_attr failed due to pass1_error */
  1757.         if (type2== (Symbol)0) return;
  1758.         break;
  1759.     /* A conversion may imply a run-time action, or may be used
  1760.      * between types of the same structure to achieve type consistency.
  1761.      * In the later case, do not emit any conversion.
  1762.      * In both cases however, a range check may be needed.
  1763.      */
  1764.  
  1765.     case as_convert:
  1766.         t_node = N_AST1(expn);
  1767.         expn1 = N_AST2(expn);
  1768.         target_type = N_UNQ(t_node);
  1769.         type2 = target_type;
  1770.         types = N_PTYPES(expn1);
  1771.         /* Apply the preference rule to choose a universal meaning for
  1772.          * the expression in case of overloading of operators.
  1773.          */
  1774.         /*tu = set_inter(types, univ_types);*/
  1775.         tu = set_new(0);
  1776.         if (set_mem((char *) symbol_universal_integer, types))
  1777.             tu = set_with(tu, (char *) symbol_universal_integer);
  1778.         if (set_mem((char *) symbol_universal_real, types))
  1779.             tu = set_with(tu, (char *) symbol_universal_real);
  1780.         if (set_size(types) > 1 && set_size(tu) == 1)
  1781.             types = tu;
  1782.         else set_free(tu);
  1783.  
  1784.         /* Verify that original expression is unambiguous. */
  1785.         if (set_size(types) != 1) {
  1786. #ifdef ERRNUM
  1787.             errmsgn(256, 257, expn1);
  1788. #else
  1789.             errmsg("ambiguous expression for conversion", "4.6", expn1);
  1790. #endif
  1791.             return;
  1792.         }
  1793.         else {
  1794.             t = (Symbol) set_arb(types);
  1795.             /*    resolve2(expn1, t);  */
  1796.             if (is_numeric(t) && is_numeric(target_type)) {
  1797.                 /* conversions between any two numeric types are allowed. */
  1798.                 /* all done */
  1799.  
  1800.                 resolve2 (expn1, t);
  1801.                 N_AST2 (expn) = expn1;
  1802.                 /*        N_AST1 (expn) = new_name_node (t); */
  1803.                 N_TYPE (expn) = target_type;
  1804.             }
  1805.             /* conversion of records with discriminant will be valid if
  1806.              *   the discriminants have the same values
  1807.              */
  1808.             else if (is_record (target_type) && has_discriminants (target_type)
  1809.               && (root_type (target_type) == root_type (t))) {
  1810.                 resolve2 (expn1, t);
  1811.                 N_KIND (expn) = as_qual_discr;
  1812.                 N_AST1 (expn) = expn1;
  1813.                 N_AST2 (expn) = (Node) 0;
  1814.                 N_TYPE (expn) = target_type;
  1815.             }
  1816.             /* conversion of access values pointing to arrays will be valid
  1817.              * if the indexes of the designated type have the same values
  1818.              */
  1819.  
  1820.             else if (is_access (target_type)
  1821.               && is_array (designated_type(target_type))
  1822.               && (root_type (target_type) == root_type (t))) {
  1823.                 resolve2 (expn1, t);
  1824.                 N_KIND (expn) = as_qual_aindex;
  1825.                 N_AST1 (expn) = expn1;
  1826.                 N_AST2 (expn) = (Node) 0;
  1827.                 N_TYPE (expn) = target_type;
  1828.             }
  1829.             /* conversion of access values pointing to records with discriminant
  1830.              * will be valid if the discriminants of the designated type have
  1831.              * the same values
  1832.              */
  1833.  
  1834.             else if (is_access (target_type)
  1835.               && is_record (designated_type(target_type))
  1836.               && has_discriminants (designated_type(target_type))
  1837.               && (root_type (target_type) == root_type (t))) {
  1838.                 resolve2 (expn1, t);
  1839.                 N_KIND (expn) = as_qual_adiscr;
  1840.                 N_AST1 (expn) = expn1;
  1841.                 N_AST2 (expn) = (Node) 0;
  1842.                 N_TYPE (expn) = target_type;
  1843.             }
  1844.  
  1845.             else if (root_type(target_type) == root_type(t)) {
  1846.                 /* conversions among types derived from a common root. In
  1847.                  * the absence of representation specifications, this is a
  1848.                  * noop, indicated here by having the same type on both sides
  1849.                  */
  1850.                 resolve2 (expn1, t);
  1851.                 N_AST2 (expn) = expn1;
  1852.                 /* N_AST1 (expn) = new_name_node (t); */
  1853.                 N_TYPE (expn) = target_type;
  1854.             }
  1855.             else if (is_array(target_type)) {
  1856.                 /* conversion between array types are allowed, if types of
  1857.                  * indices are convertible and component types are the same.
  1858.                  */
  1859.                 exists = FALSE;
  1860.                 if ( is_array(t)
  1861.                   && no_dimensions(t) == no_dimensions(target_type))
  1862.                     exists = TRUE;
  1863.                 if (exists) {
  1864.                     for (i = 1; i <= no_dimensions(t); i++) {
  1865.                         if (root_type((Symbol)index_types(target_type)[i])
  1866.                            != root_type((Symbol)index_types(t)[i])) {
  1867.                             exists = FALSE; 
  1868.                             break;
  1869.                         }
  1870.                     }
  1871.                 }
  1872.                 if (exists) {
  1873.                     if ( base_type((Symbol)component_type(target_type))
  1874.                       != base_type((Symbol) component_type(t)))
  1875.                         exists = FALSE;
  1876.                 }
  1877.                 if (exists) {          /* convertible */
  1878.                     /* the following lines have been translated from the Setl
  1879.                      * version
  1880.                      */
  1881.  
  1882.                     if (is_access (component_type (t))) {
  1883.                         c1 = designated_type (component_type (t));
  1884.                         c2 = designated_type (component_type (target_type));
  1885.                     }
  1886.                     else {
  1887.                         c1 = component_type (t);
  1888.                         c2 = component_type (target_type);
  1889.                     }
  1890.                     if ((can_constrain (c1)) != (can_constrain (c2))) {
  1891. #ifdef ERRNUM
  1892.                         l_errmsgn(480, 481, 482, expn);
  1893. #else
  1894.                         errmsg_l ("component types in array conversion must",
  1895.                           " be both constrained or unconstrained", 
  1896.                           "4.6 (11)", expn);
  1897. #endif
  1898.                         return;
  1899.                     }
  1900.                     resolve2 (expn1, t);
  1901.                     N_AST2 (expn) = expn1;
  1902.                     N_TYPE (expn) = target_type;
  1903.  
  1904.                     check_array_conversion(expn, t, target_type);
  1905.                 }
  1906.                 else {
  1907. #ifdef ERRNUM
  1908.                     errmsgn(258, 257, expn);
  1909. #else
  1910.                     errmsg("Invalid array conversion", "4.6", expn);
  1911. #endif
  1912.                     return;
  1913.                 }
  1914.             }
  1915.             else {
  1916. #ifdef ERRNUM
  1917.                 id_errmsgn(259, target_type, 257, expn);
  1918. #else
  1919.                 errmsg_id("cannot convert to %", target_type, "4.6", expn);
  1920. #endif
  1921.             }
  1922.         }
  1923.         /* if (N_KIND(expn) == as_insert) expn = N_AST1(expn);
  1924.          *        N_TYPE(expn) = base_type(type2);
  1925.          *       the result of the conversion must belong to the target subtype.
  1926.          *        if (!is_array(t)) {
  1927.          *            apply_constraint(expn, type2);
  1928.          */
  1929.  
  1930.         apply_constraint (expn, target_type);
  1931.         break;
  1932.     case as_qualify:
  1933.  
  1934.         /* proc resolve2_qualify(expn, context_type);
  1935.          * sem_trace3(3, 'At proc resolve2_qualify ', expn);
  1936.          * [-, to_type, expn1] := expn;
  1937.          * $ No sliding for aggregates here.
  1938.          * may_others := full_others;
  1939.          * full_others := true;
  1940.          * expn2 := eval_static(apply_constraint(resolve2(expn1, to_type),
  1941.          * to_type));
  1942.          * full_others := may_others;                 
  1943.          * return [['qualify', expn2], to_type];
  1944.          */
  1945.         t_node = N_AST1(expn);
  1946.         expn1 = N_AST2(expn);
  1947.         type2 = N_UNQ(t_node);
  1948.  
  1949.         /* This is non-sliding context for aggregates. */
  1950.         may_others = full_others;
  1951.         full_others = TRUE;
  1952.         resolve2(expn1, type2);
  1953.         eval_static(expn1);
  1954.  
  1955.         apply_constraint(expn1, type2);            /* impose checks. */
  1956.  
  1957.         full_others = may_others;
  1958.         break;
  1959.     /* For a subtype, complete the evaluation of the bounds.
  1960.      * If the bounds are literal, the type may be a universal one.
  1961.      * replace it now by the corresponding non-literal type.
  1962.      */
  1963.     case as_subtype:
  1964.         type_node = N_AST1(expn);
  1965.         constraint = N_AST2(expn);
  1966.         low = N_AST1(constraint);
  1967.         high = N_AST2(constraint);
  1968.         /* If the bounds are overloaded, the subtype itself may be an
  1969.          * overloaded expression. Extract the type(s) that are compatible
  1970.          * with context .
  1971.          */
  1972.         ntypes = set_new(0);
  1973.         FORSET(ntype_sym = (Symbol), types, fs1);
  1974.             if (compatible_types(context_typ, ntype_sym))
  1975.                 ntypes = set_with(ntypes, (char *) ntype_sym);
  1976.         ENDFORSET(fs1); 
  1977.         set_free(types);
  1978.         types = ntypes;
  1979.         /* Make sure that only one type is possible. */
  1980.         if (set_size(types) > 1) {
  1981.             /*types = set_diff(types, univ_types);*/
  1982.             ntypes = set_new(0);
  1983.             FORSET(ntype_sym = (Symbol), types, fs1);
  1984.                 if (ntype_sym != symbol_universal_integer
  1985.                   && ntype_sym != symbol_universal_real)
  1986.                     ntypes = set_with(ntypes, (char *) ntype_sym);
  1987.             ENDFORSET(fs1); 
  1988.             set_free(types); 
  1989.             types = ntypes;
  1990.         }
  1991.         if (set_size(types) != 1) {
  1992.             type_error(set_new1((char *)symbol_any), context_typ, 
  1993.               set_size(types), expn);
  1994.             N_TYPE(expn) = symbol_any;
  1995.             return;
  1996.         }
  1997.         else
  1998.             b_type = base_type((Symbol)set_arb(types));
  1999.  
  2000.         /* In the case of a range in a membership op, the type may be a real
  2001.          * one, in which case the precision is inherited from the context .
  2002.          */
  2003.         rtype = root_type(context_typ);
  2004.  
  2005.         if (rtype == symbol_float || rtype == symbol_universal_real)
  2006.             kind = as_digits;
  2007.         else if (is_fixed_type(rtype))
  2008.             kind = as_delta;
  2009.         else
  2010.             kind = as_range;/* $ Discrete type. */
  2011.  
  2012.         if (type_node != OPT_NODE)
  2013.             b_type = N_UNQ(type_node);
  2014.         else {
  2015.             if (kind == as_range) {
  2016.                 if (b_type == symbol_universal_integer) {
  2017.                     b_type = symbol_integer;
  2018.                     if (context_typ == symbol_universal_integer
  2019.                       && (N_KIND(low) == as_op 
  2020.                       || N_KIND(low) == as_un_op 
  2021.                       || N_KIND(high) == as_op
  2022.                       || N_KIND(high) == as_un_op)) {
  2023.                         /* i.e. discrete range in arr def. or iteration rule.*/
  2024.                         /* Not a literal, named number, or attribute(3.6.1(2))*/
  2025. #ifdef ERRNUM
  2026.                         l_errmsgn(260, 261, 195, expn);
  2027. #else
  2028.                         errmsg_l("Invalid universal expression in",
  2029.                           " discrete range", "3.6.1", expn);
  2030. #endif
  2031.                         N_TYPE(expn) = symbol_any;
  2032.                         return;
  2033.                     }
  2034.                 }
  2035.             }
  2036.             else if (kind == as_delta)
  2037.                 b_type = context_typ;
  2038.             else if (kind == as_digits)
  2039.                 b_type = symbol_float;
  2040.         }
  2041.         /* If the type name was not specified, then it is the type
  2042.          * of the bounds.
  2043.          */
  2044.         if (type_node == OPT_NODE) {
  2045.             type_node = node_new(as_simple_name);
  2046.             copy_span(constraint, type_node);
  2047.             N_UNQ(type_node) = b_type;
  2048.             N_AST1(expn) = type_node;
  2049.             N_AST2(expn) = constraint;
  2050.             if (N_AST3_DEFINED(N_KIND(expn))) N_AST3(expn) = (Node)0;
  2051.             if (N_AST4_DEFINED(N_KIND(expn))) N_AST4(expn) = (Node)0;
  2052.         }
  2053.         resolve2(low, b_type);
  2054.         resolve2(high, b_type);
  2055.         /* An index constraint may depend on a discriminant . Verify that
  2056.          * if a discriminant appears, it is by itself, and not as part of
  2057.          * a larger expression. 
  2058.          */
  2059.         check_discriminant(low);
  2060.         check_discriminant(high);
  2061.         eval_static(low);
  2062.         eval_static(high);
  2063.         if (is_discrete_type(b_type)) check_bounds_in_range(low, high, b_type);
  2064.  
  2065.         /* No constraint is imposed on the subtype node itself.*/
  2066.         type2 = b_type;
  2067.         context_typ = b_type;
  2068.         break;
  2069.     case as_call_or_index:
  2070.         /* Find the tree which has a type compatible with the context, and
  2071.          * resolve it.
  2072.           */
  2073.         call_node = N_AST1(expn);
  2074.         index_node = N_AST2(expn);
  2075.         exists = FALSE;
  2076.         FORSET(t = (Symbol), N_PTYPES(call_node), fs1);
  2077.             if (compatible_types(t, context_typ)) {
  2078.                 exists = TRUE;
  2079.                 break;
  2080.             }
  2081.         ENDFORSET(fs1);
  2082.         if (exists) {
  2083.             node = call_node;
  2084.             exists = FALSE;
  2085.             FORSET(t2 = (Symbol), N_PTYPES(index_node), fs1);
  2086.                 if( compatible_types(t2, context_typ)) {
  2087.                     exists = TRUE;
  2088.                     break;
  2089.                 }
  2090.             ENDFORSET(fs1);
  2091.             if (exists) {
  2092.                 remove_conversions(call_node);    /* last chance */
  2093.                 remove_conversions(index_node);
  2094.                 exists = FALSE;
  2095.                 FORSET(t = (Symbol), N_PTYPES(call_node), fs1);
  2096.                     if ( compatible_types(t, context_typ)) {
  2097.                         exists = TRUE;
  2098.                         break;
  2099.                     }
  2100.                 ENDFORSET(fs1);
  2101.                 if (exists) {
  2102.                     node = call_node;
  2103.                     exists = FALSE;
  2104.                     FORSET(t2 = (Symbol), N_PTYPES(index_node), fs1);
  2105.                         if (compatible_types(t2, context_typ)) {
  2106.                             exists = TRUE;
  2107.                             break;
  2108.                         }
  2109.                     ENDFORSET(fs1);
  2110.                     if (exists) {
  2111. #ifdef TBSL
  2112.                         type_error(set_new1('call or index'), context_typ, 2,
  2113.                           expn);
  2114. #endif
  2115.                     }
  2116.                 }
  2117.                 else node = index_node;
  2118.             }
  2119.         }
  2120.         else node = index_node;
  2121.         resolve2(node, context_typ);
  2122.         copy_attributes(node, expn);
  2123.         type2 = N_TYPE(node);
  2124.         break;
  2125.     default:
  2126.         /* Other operators require no propagation */
  2127.         type2 = (Symbol) set_arb(types);
  2128.         break;
  2129.     }
  2130.  
  2131.     if (compatible_types(context_typ, type2)) N_TYPE(expn) = type2;
  2132.     else {
  2133. #ifdef ERRNUM
  2134.         type_errmsgn(262, context_typ, 10, expn);
  2135. #else
  2136.         errmsg_type("Incorrect type for expression. Expect %", context_typ,
  2137.           "none", expn);
  2138. #endif
  2139.     }
  2140. }
  2141.  
  2142. static Symbol resolve2_attr(Node expn, Symbol context_typ)    /*;resolve2_attr*/
  2143. {
  2144.     Forset    fs1;
  2145.     Set        types;
  2146.     int        attrkind, dim, out_c;
  2147.     Symbol    type2;
  2148.     Const    con;
  2149.     Node    attr_node, arg1, arg2;
  2150.     Set        types1, types2;
  2151.     Symbol    type1, t2, itype1;
  2152.  
  2153.     types = N_PTYPES(expn);
  2154.     attr_node = N_AST1(expn);
  2155.     arg1 = N_AST2(expn);
  2156.     arg2 = N_AST3(expn);
  2157.     /*  The type of the right argument is determined by the attribute,
  2158.      *  and has already been evaluated in the case of array attributes.
  2159.      */
  2160.     /*attribute = N_VAL(attr_node); -- should be dead  ds 3-13-86*/
  2161.     attrkind = (int) attribute_kind(expn);
  2162.     types1 = N_PTYPES(arg1);
  2163.     types2 = N_PTYPES(arg2);
  2164.     type1 = (Symbol) set_arb(types1);
  2165.  
  2166.     if (attrkind == ATTR_PRED 
  2167.       ||attrkind == ATTR_SUCC 
  2168.       ||attrkind == ATTR_POS 
  2169.       ||attrkind == ATTR_IMAGE)
  2170.         t2 = base_type(type1);
  2171.     else if (attrkind == ATTR_VALUE)
  2172.         t2 = symbol_string;
  2173.     else if (attrkind == ATTR_VAL) {
  2174.         Symbol t;
  2175.         Set otypes2;
  2176.         otypes2 = types2;
  2177.         types2 = set_new(0);
  2178.         FORSET(t = (Symbol), otypes2, fs1);
  2179.             if (compatible_types(t, symbol_integer_type))
  2180.                 types2 = set_with(types2, (char *) t);
  2181.         ENDFORSET(fs1);
  2182.         if (set_size(types2) == 0) {
  2183. #ifdef ERRNUM
  2184.             errmsgn(263, 233, arg2);
  2185. #else
  2186.             errmsg("Second argument of VAL must be of some integer type",
  2187.              "Annex A", arg2);
  2188. #endif
  2189.             return (Symbol)0;
  2190.         }
  2191.         else if (set_size(types2) == 1)
  2192.             t2 = (Symbol) set_arb(types2);
  2193.         else if (set_mem((char *) symbol_universal_integer, types2))
  2194.             t2 = symbol_universal_integer;
  2195.         else {
  2196. #ifdef ERRNUM
  2197.             errmsgn(264, 233, arg2);
  2198. #else
  2199.             errmsg("ambiguous argument for attribute VAL", "Annex A", arg2);
  2200. #endif
  2201.             return (Symbol)0;
  2202.         }
  2203.     }
  2204.     else
  2205.         t2 = symbol_integer;
  2206.  
  2207.     if  (attrkind != ATTR_O_FIRST && attrkind != ATTR_T_FIRST
  2208.       && attrkind != ATTR_O_LAST && attrkind != ATTR_T_LAST
  2209.       && attrkind != ATTR_O_RANGE && attrkind != ATTR_T_RANGE
  2210.       && attrkind != ATTR_O_LENGTH && attrkind != ATTR_T_LENGTH)
  2211.         resolve2(arg2, t2);
  2212.     if (t2 == symbol_universal_integer)        /* possible for VAL */
  2213.         specialize(arg2, symbol_integer);
  2214.     if ((attrkind == ATTR_POSITION || attrkind == ATTR_FIRST_BIT
  2215.       || attrkind == ATTR_LAST_BIT) && N_KIND(arg1) != as_selector) {
  2216. #ifdef ERRNUM
  2217.         errmsgn(265, 266, arg1);
  2218. #else
  2219.         errmsg("attribute must apply to selected component", "13.7.2", arg1);
  2220. #endif
  2221.     }
  2222.     /*
  2223.      * If the left argument is a type, or if it is a constrained
  2224.      * object, then evaluate the attribute on the type, statically if
  2225.      * possible.
  2226.      */
  2227.     /*
  2228.      * All attributes, except those that  are functions,  can be applied
  2229.      * to  an out parameter, because  they do not require reading of the
  2230.      * object, or read  only its bounds. On the other hand,      if the pre-
  2231.      * fix is an access type, it cannot be an an out parameter (4.1(4)).
  2232.      */
  2233.     out_c = out_context; /* Save current setting*/
  2234.     out_context = !reads_prefix(attrkind, type1);
  2235.     itype1 = type1;
  2236.  
  2237.     if (is_array(type1)
  2238.       && (attrkind == ATTR_O_FIRST || attrkind == ATTR_T_FIRST
  2239.       || attrkind == ATTR_O_LAST || attrkind == ATTR_T_LAST
  2240.       || attrkind == ATTR_O_RANGE || attrkind == ATTR_T_RANGE
  2241.       || attrkind == ATTR_O_LENGTH || attrkind == ATTR_T_LENGTH)) {
  2242.         /*    The second argument indicates the dimension whose attribute
  2243.          * is sought. It must be a static integer(this has been checked
  2244.          * already).
  2245.          */
  2246.         if (!is_static_expr(arg2))
  2247.             dim = 1;    /* By default. */
  2248.         else {
  2249.             con = (Const) N_VAL(arg2);
  2250.             dim = con->const_value.const_int;
  2251.         }
  2252.         itype1 = (Symbol) (index_types(type1)[dim]);
  2253.     }
  2254.  
  2255.     if (is_type_node(arg1)) {
  2256.         /* This might cause problems in eval_static. */
  2257.         /* In at least some cases, N_PTYPES has been set (cf. 4a.c line 1009),
  2258.          * so here we clear N_PTYPES lest it be mistaken for N_TYPE (DS 9-18-86)
  2259.          */
  2260.         N_PTYPES(arg1) = (Set) 0;
  2261.         N_UNQ(arg1) = itype1;
  2262.     }
  2263.     else if (attrkind == ATTR_COUNT) {
  2264.         /* entry name is fully resolved in first pass. */
  2265.         ;        /* no op */
  2266.     }
  2267.     else {
  2268.         resolve2(arg1, type1);
  2269.     }
  2270.     out_context = out_c; /* restore    */
  2271.  
  2272.     if (in_univ_attributes(attrkind)) {
  2273.         if (is_static_expr(expn)) {
  2274.             /* Specialize value if context is not universal.*/
  2275.             eval_static(expn);
  2276.             specialize(expn, context_typ);
  2277.         }
  2278.         /* in nay case indicate desired context type for subsequent conversion*/
  2279.         type2 = base_type(context_typ);
  2280.     }
  2281.     else {                 /*$$$ TBSL: check for FIRST_BIT, LAST_BIT*/
  2282.         type2 = (Symbol) set_arb(types);
  2283.     }
  2284.     return type2;
  2285. }
  2286.  
  2287. static int in_univ_attributes(int attrkind)                /*;in_univ_attributes*/
  2288. {
  2289.     /* test if type of attribute is universal type */
  2290.     static int attrs[] = {
  2291.         ATTR_AFT, ATTR_COUNT, ATTR_DIGITS, ATTR_EMAX, ATTR_FIRST_BIT, ATTR_FORE,
  2292.         ATTR_LAST_BIT, ATTR_O_LENGTH, ATTR_T_LENGTH, ATTR_MACHINE_EMAX,
  2293.         ATTR_MACHINE_EMIN, ATTR_MACHINE_MANTISSA, ATTR_MACHINE_RADIX,
  2294.         ATTR_MANTISSA, ATTR_POS, ATTR_POSITION, ATTR_SAFE_EMAX, ATTR_O_SIZE,
  2295.         ATTR_T_SIZE, ATTR_STORAGE_SIZE, ATTR_WIDTH, ATTR_DELTA, ATTR_EPSILON,
  2296.         ATTR_LARGE, ATTR_SMALL, ATTR_SAFE_LARGE, ATTR_SAFE_SMALL,
  2297.         ATTR_O_CONSTRAINED, ATTR_T_CONSTRAINED, ATTR_MACHINE_OVERFLOWS,
  2298.         ATTR_MACHINE_ROUNDS, ATTR_CALLABLE, ATTR_TERMINATED, 999    };
  2299.     int i;
  2300.     for (i = 0; ; i++) {
  2301.         if (attrs[i] == 999) return FALSE;
  2302.         if (attrs[i] == attrkind) return TRUE;
  2303.     }
  2304. }
  2305.  
  2306. static void check_bounds_in_range(Node low, Node high, Symbol b_type)
  2307.                                                     /*;check_bounds_in_range*/
  2308. {
  2309.     /* check if the bounds of an array with a subtype_declaration are
  2310.      * in the bounds of the base_type, when static. (When not static,
  2311.      * a qual_range is introduced on as_convert).
  2312.      */
  2313.  
  2314.     Node    lbd_range, ubd_range;
  2315.     int     low_val, high_val, lbd_val, ubd_val;
  2316.     Tuple   b_range_tup;
  2317.     Const      low_const, high_const, lbd_const, ubd_const;
  2318.  
  2319.     b_range_tup   = SIGNATURE(b_type);
  2320.     lbd_range     = (Node) b_range_tup[2];
  2321.     ubd_range     = (Node) b_range_tup[3];
  2322.     if (N_KIND(low) == as_qualify) low = N_AST2(low);
  2323.     if (N_KIND(high) == as_qualify) high = N_AST2(high);
  2324.  
  2325.     if (is_static_expr(low) && is_static_expr(high)
  2326.       && is_static_expr(lbd_range) && is_static_expr(ubd_range))  {
  2327.         low_const = (Const) N_VAL(low);
  2328.         high_const = (Const) N_VAL(high);
  2329.         lbd_const = (Const) N_VAL(lbd_range);
  2330.         ubd_const = (Const) N_VAL(ubd_range);
  2331.         const_check(low_const, CONST_INT);
  2332.         const_check(high_const, CONST_INT);
  2333.         const_check(lbd_const, CONST_INT);
  2334.         const_check(ubd_const, CONST_INT);
  2335.         low_val = INTV(low_const);
  2336.         high_val = INTV(high_const);
  2337.         lbd_val = INTV(lbd_const);
  2338.         ubd_val = INTV(ubd_const);
  2339.  
  2340.         if ((lbd_val > ubd_val && low_val <= high_val)
  2341.           || ((low_val <= high_val) && (low_val < lbd_val || low_val > ubd_val
  2342.           || high_val > ubd_val || high_val < lbd_val))) {
  2343.             create_raise(low, symbol_constraint_error);
  2344.             return;
  2345.         }
  2346.     }
  2347. }
  2348.  
  2349. static void check_array_conversion(Node expn, Symbol from_t, Symbol to_t)
  2350.                                                 /*;check_array_conversion */
  2351. {
  2352.     /* verify that in an array conversion, source and target component types
  2353.      * have the same constraints.
  2354.      */
  2355.  
  2356.     Symbol from_c, to_c;
  2357.     Tuple  checks;
  2358.     Tuple from_i, to_i;
  2359.     int i;
  2360.  
  2361.     checks = tup_new(0);
  2362.  
  2363.     from_c = component_type(from_t);
  2364.     to_c = component_type(to_t);
  2365.  
  2366.     while (is_access (from_c)) {
  2367.         from_c = designated_type (from_c);
  2368.         to_c = designated_type (to_c); 
  2369.     }
  2370.  
  2371.     if (from_c == to_c) {
  2372.         ;
  2373.     }
  2374.     else if (is_scalar_type(from_c))
  2375.         checks = tup_with(checks, (char *) new_check_bounds_node(from_c, to_c));
  2376.     else if (is_record (from_c) && has_discriminants (from_c))
  2377.         checks = new_check_disc_node (from_c, to_c); 
  2378.     else if (is_array(from_c)) {
  2379.         /* index subtypes must be equal */
  2380.         from_i = index_types(from_c);
  2381.         to_i = index_types(to_c);
  2382.         for (i = 1; i<= tup_size(from_i); i++) {
  2383.             checks = tup_with(checks,
  2384.               (char *) new_check_bounds_node( (Symbol)from_i[i],
  2385.               (Symbol)to_i[i]));
  2386.         }
  2387.     }
  2388.     /* TBSL: check values of discriminants for record types. */
  2389.  
  2390.     if (tup_size(checks) > 0) {
  2391.         make_insert_node(expn, checks, copy_node(expn));
  2392.         /* This line has to be deleted in order to reuse the function
  2393.       in case of conversion of array access values 
  2394.       N_TYPE(expn) = to_t; */
  2395.     }
  2396. }
  2397.  
  2398. static int reads_prefix(int attrkind, Symbol type1)
  2399.                                                             /*;reads_prefix*/
  2400. {
  2401.     /* Used to determine whether an attribute can apply to an out parameter.
  2402.      * see tests A62006d, B62006c, B85007C.
  2403.      */
  2404.  
  2405.     if  (attrkind == ATTR_BASE
  2406.       || attrkind == ATTR_POS
  2407.       || attrkind == ATTR_PRED
  2408.       || attrkind == ATTR_SUCC
  2409.       || attrkind == ATTR_VAL
  2410.       || attrkind == ATTR_VALUE)
  2411.         return TRUE;
  2412.  
  2413.     if (is_access(type1))  return TRUE;
  2414.     return FALSE;
  2415. }
  2416.